home *** CD-ROM | disk | FTP | other *** search
/ Supercompiler 1997 / SUPERCOMPILER97.iso / Delphi 3.0 / DATA.Z / comctrls.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1997-01-29  |  349.8 KB  |  12,727 lines
  1.  
  2. {*******************************************************}
  3. {                                                       }
  4. {       Delphi Visual Component Library                 }
  5. {                                                       }
  6. {       Copyright (c) 1996,97 Borland International     }
  7. {                                                       }
  8. {*******************************************************}
  9.  
  10. unit ComCtrls;
  11.  
  12. {$R-}
  13.  
  14. interface
  15.  
  16. uses Messages, Windows, SysUtils, CommCtrl, Classes, Controls, Forms,
  17.   Menus, Graphics, StdCtrls, RichEdit, ToolWin;
  18.  
  19. type
  20.   TTabChangingEvent = procedure(Sender: TObject;
  21.     var AllowChange: Boolean) of object;
  22.  
  23.   TTabPosition = (tpTop, tpBottom); // tpLeft, tpRight cause font problems
  24.  
  25.   TCustomTabControl = class(TWinControl)
  26.   private
  27.     FTabs: TStrings;
  28.     FSaveTabs: TStringList;
  29.     FSaveTabIndex: Integer;
  30.     FTabSize: TSmallPoint;
  31.     FMultiLine: Boolean;
  32.     FUpdating: Boolean;
  33.     FHotTrack: Boolean;
  34.     FScrollOpposite: Boolean;
  35.     FTabPosition: TTabPosition;
  36.     FOnChange: TNotifyEvent;
  37.     FOnChanging: TTabChangingEvent;
  38.     function GetDisplayRect: TRect;
  39.     function GetTabIndex: Integer;
  40.     procedure SetHotTrack(Value: Boolean);
  41.     procedure SetMultiLine(Value: Boolean);
  42.     procedure SetScrollOpposite(Value: Boolean);
  43.     procedure SetTabHeight(Value: Smallint);
  44.     procedure SetTabIndex(Value: Integer);
  45.     procedure SetTabPosition(Value: TTabPosition);
  46.     procedure SetTabs(Value: TStrings);
  47.     procedure SetTabWidth(Value: Smallint);
  48.     procedure TabsChanged;
  49.     procedure UpdateTabSize;
  50.     procedure WMDestroy(var Message: TWMDestroy); message WM_DESTROY;
  51.     procedure WMEraseBkgnd(var Message: TMessage); message WM_ERASEBKGND;
  52.     procedure WMSize(var Message: TMessage); message WM_SIZE;
  53.     procedure CMFontChanged(var Message); message CM_FONTCHANGED;
  54.     procedure CMSysColorChange(var Message: TMessage); message CM_SYSCOLORCHANGE;
  55.     procedure CMTabStopChanged(var Message: TMessage); message CM_TABSTOPCHANGED;
  56.     procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY;
  57.   protected
  58.     procedure AlignControls(AControl: TControl; var Rect: TRect); override;
  59.     function CanChange: Boolean; dynamic;
  60.     procedure Change; dynamic;
  61.     procedure CreateParams(var Params: TCreateParams); override;
  62.     procedure CreateWnd; override;
  63.     procedure DestroyWnd; override;
  64.     property DisplayRect: TRect read GetDisplayRect;
  65.     property HotTrack: Boolean read FHotTrack write SetHotTrack default False;
  66.     property MultiLine: Boolean read FMultiLine write SetMultiLine default False;
  67.     property ScrollOpposite: Boolean read FScrollOpposite
  68.       write SetScrollOpposite default False;
  69.     property TabHeight: Smallint read FTabSize.Y write SetTabHeight default 0;
  70.     property TabIndex: Integer read GetTabIndex write SetTabIndex default -1;
  71.     property TabPosition: TTabPosition read FTabPosition write SetTabPosition
  72.       default tpTop;
  73.     property Tabs: TStrings read FTabs write SetTabs;
  74.     property TabWidth: Smallint read FTabSize.X write SetTabWidth default 0;
  75.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  76.     property OnChanging: TTabChangingEvent read FOnChanging write FOnChanging;
  77.   public
  78.     constructor Create(AOwner: TComponent); override;
  79.     destructor Destroy; override;
  80.     property TabStop default True;
  81.   end;
  82.  
  83.   TTabControl = class(TCustomTabControl)
  84.   public
  85.     property DisplayRect;
  86.   published
  87.     property Align;
  88.     property DragCursor;
  89.     property DragMode;
  90.     property Enabled;
  91.     property Font;
  92.     property HotTrack;
  93.     property MultiLine;
  94.     property ParentFont;
  95.     property ParentShowHint;
  96.     property PopupMenu;
  97.     property ScrollOpposite;
  98.     property ShowHint;
  99.     property TabHeight;
  100.     property TabIndex;
  101.     property TabOrder;
  102.     property TabPosition;
  103.     property Tabs;
  104.     property TabStop;
  105.     property TabWidth;
  106.     property Visible;
  107.     property OnChange;
  108.     property OnChanging;
  109.     property OnDragDrop;
  110.     property OnDragOver;
  111.     property OnEndDrag;
  112.     property OnEnter;
  113.     property OnExit;
  114.     property OnMouseDown;
  115.     property OnMouseMove;
  116.     property OnMouseUp;
  117.     property OnStartDrag;
  118.   end;
  119.  
  120.   TPageControl = class;
  121.  
  122.   TTabSheet = class(TWinControl)
  123.   private
  124.     FPageControl: TPageControl;
  125.     FTabVisible: Boolean;
  126.     FTabShowing: Boolean;
  127.     function GetPageIndex: Integer;
  128.     function GetTabIndex: Integer;
  129.     procedure SetPageControl(APageControl: TPageControl);
  130.     procedure SetPageIndex(Value: Integer);
  131.     procedure SetTabShowing(Value: Boolean);
  132.     procedure SetTabVisible(Value: Boolean);
  133.     procedure UpdateTabShowing;
  134.     procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
  135.   protected
  136.     procedure CreateParams(var Params: TCreateParams); override;
  137.     procedure ReadState(Reader: TReader); override;
  138.   public
  139.     constructor Create(AOwner: TComponent); override;
  140.     destructor Destroy; override;
  141.     property PageControl: TPageControl read FPageControl write SetPageControl;
  142.     property TabIndex: Integer read GetTabIndex;
  143.   published
  144.     property Caption;
  145.     property Enabled;
  146.     property Font;
  147.     property Height stored False;
  148.     property Left stored False;
  149.     property PageIndex: Integer read GetPageIndex write SetPageIndex stored False;
  150.     property ParentFont;
  151.     property ParentShowHint;
  152.     property PopupMenu;
  153.     property ShowHint;
  154.     property TabVisible: Boolean read FTabVisible write SetTabVisible default True;
  155.     property Top stored False;
  156.     property Visible stored False;
  157.     property Width stored False;
  158.     property OnDragDrop;
  159.     property OnDragOver;
  160.     property OnEnter;
  161.     property OnExit;
  162.     property OnMouseDown;
  163.     property OnMouseMove;
  164.     property OnMouseUp;
  165.   end;
  166.  
  167.   TPageControl = class(TCustomTabControl)
  168.   private
  169.     FPages: TList;
  170.     FActivePage: TTabSheet;
  171.     procedure ChangeActivePage(Page: TTabSheet);
  172.     procedure DeleteTab(Page: TTabSheet);
  173.     function GetPage(Index: Integer): TTabSheet;
  174.     function GetPageCount: Integer;
  175.     procedure InsertPage(Page: TTabSheet);
  176.     procedure InsertTab(Page: TTabSheet);
  177.     procedure MoveTab(CurIndex, NewIndex: Integer);
  178.     procedure RemovePage(Page: TTabSheet);
  179.     procedure SetActivePage(Page: TTabSheet);
  180.     procedure UpdateTab(Page: TTabSheet);
  181.     procedure UpdateActivePage;
  182.     procedure CMDesignHitTest(var Message: TCMDesignHitTest); message CM_DESIGNHITTEST;
  183.     procedure CMDialogKey(var Message: TCMDialogKey); message CM_DIALOGKEY;
  184.   protected
  185.     procedure Change; override;
  186.     procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
  187.     procedure SetChildOrder(Child: TComponent; Order: Integer); override;
  188.     procedure ShowControl(AControl: TControl); override;
  189.   public
  190.     constructor Create(AOwner: TComponent); override;
  191.     destructor Destroy; override;
  192.     function FindNextPage(CurPage: TTabSheet;
  193.       GoForward, CheckTabVisible: Boolean): TTabSheet;
  194.     procedure SelectNextPage(GoForward: Boolean);
  195.     property PageCount: Integer read GetPageCount;
  196.     property Pages[Index: Integer]: TTabSheet read GetPage;
  197.   published
  198.     property ActivePage: TTabSheet read FActivePage write SetActivePage;
  199.     property Align;
  200.     property DragCursor;
  201.     property DragMode;
  202.     property Enabled;
  203.     property Font;
  204.     property HotTrack;
  205.     property MultiLine;
  206.     property ParentFont;
  207.     property ParentShowHint;
  208.     property PopupMenu;
  209.     property ScrollOpposite;
  210.     property ShowHint;
  211.     property TabHeight;
  212.     property TabOrder;
  213.     property TabPosition;
  214.     property TabStop;
  215.     property TabWidth;
  216.     property Visible;
  217.     property OnChange;
  218.     property OnChanging;
  219.     property OnDragDrop;
  220.     property OnDragOver;
  221.     property OnEndDrag;
  222.     property OnEnter;
  223.     property OnExit;
  224.     property OnMouseDown;
  225.     property OnMouseMove;
  226.     property OnMouseUp;
  227.     property OnStartDrag;
  228.   end;
  229.  
  230.   TStatusBar = class;
  231.  
  232.   TStatusPanelStyle = (psText, psOwnerDraw);
  233.   TStatusPanelBevel = (pbNone, pbLowered, pbRaised);
  234.  
  235.   TStatusPanel = class(TCollectionItem)
  236.   private
  237.     FText: string;
  238.     FWidth: Integer;
  239.     FAlignment: TAlignment;
  240.     FBevel: TStatusPanelBevel;
  241.     FStyle: TStatusPanelStyle;
  242.     function GetDisplayName: string; override;
  243.     procedure SetAlignment(Value: TAlignment);
  244.     procedure SetBevel(Value: TStatusPanelBevel);
  245.     procedure SetStyle(Value: TStatusPanelStyle);
  246.     procedure SetText(const Value: string);
  247.     procedure SetWidth(Value: Integer);
  248.   public
  249.     constructor Create(Collection: TCollection); override;
  250.     procedure Assign(Source: TPersistent); override;
  251.   published
  252.     property Alignment: TAlignment read FAlignment write SetAlignment default taLeftJustify;
  253.     property Bevel: TStatusPanelBevel read FBevel write SetBevel default pbLowered;
  254.     property Style: TStatusPanelStyle read FStyle write SetStyle default psText;
  255.     property Text: string read FText write SetText;
  256.     property Width: Integer read FWidth write SetWidth;
  257.   end;
  258.  
  259.   TStatusPanels = class(TCollection)
  260.   private
  261.     FStatusBar: TStatusBar;
  262.     function GetItem(Index: Integer): TStatusPanel;
  263.     procedure SetItem(Index: Integer; Value: TStatusPanel);
  264.   protected
  265.     function GetOwner: TPersistent; override;
  266.     procedure Update(Item: TCollectionItem); override;
  267.   public
  268.     constructor Create(StatusBar: TStatusBar);
  269.     function Add: TStatusPanel;
  270.     property Items[Index: Integer]: TStatusPanel read GetItem write SetItem; default;
  271.   end;
  272.  
  273.   TDrawPanelEvent = procedure(StatusBar: TStatusBar; Panel: TStatusPanel;
  274.     const Rect: TRect) of object;
  275.  
  276.   TStatusBar = class(TWinControl)
  277.   private
  278.     FPanels: TStatusPanels;
  279.     FCanvas: TCanvas;
  280.     FSimpleText: string;
  281.     FSimplePanel: Boolean;
  282.     FSizeGrip: Boolean;
  283.     FOnDrawPanel: TDrawPanelEvent;
  284.     FOnResize: TNotifyEvent;
  285.     procedure SetPanels(Value: TStatusPanels);
  286.     procedure SetSimplePanel(Value: Boolean);
  287.     procedure SetSimpleText(const Value: string);
  288.     procedure SetSizeGrip(Value: Boolean);
  289.     procedure UpdatePanel(Index: Integer);
  290.     procedure UpdatePanels;
  291.     procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM;
  292.     procedure WMSize(var Message: TWMSize); message WM_SIZE;
  293.   protected
  294.     procedure CreateParams(var Params: TCreateParams); override;
  295.     procedure CreateWnd; override;
  296.     procedure DrawPanel(Panel: TStatusPanel; const Rect: TRect); dynamic;
  297.     procedure Resize; dynamic;
  298.   public
  299.     constructor Create(AOwner: TComponent); override;
  300.     destructor Destroy; override;
  301.     property Canvas: TCanvas read FCanvas;
  302.   published
  303.     property Align default alBottom;
  304.     property DragCursor;
  305.     property DragMode;
  306.     property Enabled;
  307.     property Font;
  308.     property Panels: TStatusPanels read FPanels write SetPanels;
  309.     property ParentFont;
  310.     property ParentShowHint;
  311.     property PopupMenu;
  312.     property ShowHint;
  313.     property SimplePanel: Boolean read FSimplePanel write SetSimplePanel;
  314.     property SimpleText: string read FSimpleText write SetSimpleText;
  315.     property SizeGrip: Boolean read FSizeGrip write SetSizeGrip default True;
  316.     property Visible;
  317.     property OnClick;
  318.     property OnDblClick;
  319.     property OnDragDrop;
  320.     property OnDragOver;
  321.     property OnEndDrag;
  322.     property OnMouseDown;
  323.     property OnMouseMove;
  324.     property OnMouseUp;
  325.     property OnDrawPanel: TDrawPanelEvent read FOnDrawPanel write FOnDrawPanel;
  326.     property OnResize: TNotifyEvent read FOnResize write FOnResize;
  327.     property OnStartDrag;
  328.   end;
  329.  
  330.   THeaderControl = class;
  331.  
  332.   THeaderSectionStyle = (hsText, hsOwnerDraw);
  333.  
  334.   THeaderSection = class(TCollectionItem)
  335.   private
  336.     FText: string;
  337.     FWidth: Integer;
  338.     FMinWidth: Integer;
  339.     FMaxWidth: Integer;
  340.     FAlignment: TAlignment;
  341.     FStyle: THeaderSectionStyle;
  342.     FAllowClick: Boolean;
  343.     function GetLeft: Integer;
  344.     function GetRight: Integer;
  345.     procedure SetAlignment(Value: TAlignment);
  346.     procedure SetMaxWidth(Value: Integer);
  347.     procedure SetMinWidth(Value: Integer);
  348.     procedure SetStyle(Value: THeaderSectionStyle);
  349.     procedure SetText(const Value: string);
  350.     procedure SetWidth(Value: Integer);
  351.   protected
  352.     function GetDisplayName: string; override;
  353.   public
  354.     constructor Create(Collection: TCollection); override;
  355.     procedure Assign(Source: TPersistent); override;
  356.     property Left: Integer read GetLeft;
  357.     property Right: Integer read GetRight;
  358.   published
  359.     property Alignment: TAlignment read FAlignment write SetAlignment default taLeftJustify;
  360.     property AllowClick: Boolean read FAllowClick write FAllowClick default True;
  361.     property MaxWidth: Integer read FMaxWidth write SetMaxWidth default 10000;
  362.     property MinWidth: Integer read FMinWidth write SetMinWidth default 0;
  363.     property Style: THeaderSectionStyle read FStyle write SetStyle default hsText;
  364.     property Text: string read FText write SetText;
  365.     property Width: Integer read FWidth write SetWidth;
  366.   end;
  367.  
  368.   THeaderSections = class(TCollection)
  369.   private
  370.     FHeaderControl: THeaderControl;
  371.     function GetItem(Index: Integer): THeaderSection;
  372.     procedure SetItem(Index: Integer; Value: THeaderSection);
  373.   protected
  374.     function GetOwner: TPersistent; override;
  375.     procedure Update(Item: TCollectionItem); override;
  376.   public
  377.     constructor Create(HeaderControl: THeaderControl);
  378.     function Add: THeaderSection;
  379.     property Items[Index: Integer]: THeaderSection read GetItem write SetItem; default;
  380.   end;
  381.  
  382.   TSectionTrackState = (tsTrackBegin, tsTrackMove, tsTrackEnd);
  383.  
  384.   TDrawSectionEvent = procedure(HeaderControl: THeaderControl;
  385.     Section: THeaderSection; const Rect: TRect; Pressed: Boolean) of object;
  386.   TSectionNotifyEvent = procedure(HeaderControl: THeaderControl;
  387.     Section: THeaderSection) of object;
  388.   TSectionTrackEvent = procedure(HeaderControl: THeaderControl;
  389.     Section: THeaderSection; Width: Integer;
  390.     State: TSectionTrackState) of object;
  391.  
  392.   THeaderControl = class(TWinControl)
  393.   private
  394.     FSections: THeaderSections;
  395.     FCanvas: TCanvas;
  396.     FHotTrack: Boolean;
  397.     FOnDrawSection: TDrawSectionEvent;
  398.     FOnResize: TNotifyEvent;
  399.     FOnSectionClick: TSectionNotifyEvent;
  400.     FOnSectionResize: TSectionNotifyEvent;
  401.     FOnSectionTrack: TSectionTrackEvent;
  402.     procedure SetHotTrack(Value: Boolean);
  403.     procedure SetSections(Value: THeaderSections);
  404.     procedure UpdateItem(Message, Index: Integer);
  405.     procedure UpdateSection(Index: Integer);
  406.     procedure UpdateSections;
  407.     procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM;
  408.     procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY;
  409.     procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
  410.     procedure WMSize(var Message: TWMSize); message WM_SIZE;
  411.     procedure WMWindowPosChanged(var Message: TWMWindowPosChanged); message WM_WINDOWPOSCHANGED;
  412.   protected
  413.     procedure CreateParams(var Params: TCreateParams); override;
  414.     procedure CreateWnd; override;
  415.     procedure DrawSection(Section: THeaderSection; const Rect: TRect;
  416.       Pressed: Boolean); dynamic;
  417.     procedure Resize; dynamic;
  418.     procedure SectionClick(Section: THeaderSection); dynamic;
  419.     procedure SectionResize(Section: THeaderSection); dynamic;
  420.     procedure SectionTrack(Section: THeaderSection; Width: Integer;
  421.       State: TSectionTrackState); dynamic;
  422.   public
  423.     constructor Create(AOwner: TComponent); override;
  424.     destructor Destroy; override;
  425.     property Canvas: TCanvas read FCanvas;
  426.   published
  427.     property Align default alTop;
  428.     property DragCursor;
  429.     property DragMode;
  430.     property Enabled;
  431.     property Font;
  432.     property HotTrack: Boolean read FHotTrack write SetHotTrack default False;
  433.     property Sections: THeaderSections read FSections write SetSections;
  434.     property ShowHint;
  435.     property ParentFont;
  436.     property ParentShowHint;
  437.     property PopupMenu;
  438.     property Visible;
  439.     property OnDragDrop;
  440.     property OnDragOver;
  441.     property OnEndDrag;
  442.     property OnMouseDown;
  443.     property OnMouseMove;
  444.     property OnMouseUp;
  445.     property OnDrawSection: TDrawSectionEvent read FOnDrawSection write FOnDrawSection;
  446.     property OnResize: TNotifyEvent read FOnResize write FOnResize;
  447.     property OnSectionClick: TSectionNotifyEvent read FOnSectionClick write FOnSectionClick;
  448.     property OnSectionResize: TSectionNotifyEvent read FOnSectionResize write FOnSectionResize;
  449.     property OnSectionTrack: TSectionTrackEvent read FOnSectionTrack write FOnSectionTrack;
  450.     property OnStartDrag;
  451.   end;
  452.  
  453. { TTreeNode }
  454.  
  455.   TCustomTreeView = class;
  456.   TTreeNodes = class;
  457.  
  458.   TNodeState = (nsCut, nsDropHilited, nsFocused, nsSelected, nsExpanded);
  459.   TNodeAttachMode = (naAdd, naAddFirst, naAddChild, naAddChildFirst, naInsert);
  460.   TAddMode = (taAddFirst, taAdd, taInsert);
  461.  
  462.   PNodeInfo = ^TNodeInfo;
  463.   TNodeInfo = packed record
  464.     ImageIndex: Integer;
  465.     SelectedIndex: Integer;
  466.     StateIndex: Integer;
  467.     OverlayIndex: Integer;
  468.     Data: Pointer;
  469.     Count: Integer;
  470.     Text: string[255];
  471.   end;
  472.  
  473.   TTreeNode = class(TPersistent)
  474.   private
  475.     FOwner: TTreeNodes;
  476.     FText: string;
  477.     FData: Pointer;
  478.     FItemId: HTreeItem;
  479.     FImageIndex: Integer;
  480.     FSelectedIndex: Integer;
  481.     FOverlayIndex: Integer;
  482.     FStateIndex: Integer;
  483.     FDeleting: Boolean;
  484.     FInTree: Boolean;
  485.     function CompareCount(CompareMe: Integer): Boolean;
  486.     function DoCanExpand(Expand: Boolean): Boolean;
  487.     procedure DoExpand(Expand: Boolean);
  488.     procedure ExpandItem(Expand: Boolean; Recurse: Boolean);
  489.     function GetAbsoluteIndex: Integer;
  490.     function GetExpanded: Boolean;
  491.     function GetLevel: Integer;
  492.     function GetParent: TTreeNode;
  493.     function GetChildren: Boolean;
  494.     function GetCut: Boolean;
  495.     function GetDropTarget: Boolean;
  496.     function GetFocused: Boolean;
  497.     function GetIndex: Integer;
  498.     function GetItem(Index: Integer): TTreeNode;
  499.     function GetSelected: Boolean;
  500.     function GetState(NodeState: TNodeState): Boolean;
  501.     function GetCount: Integer;
  502.     function GetTreeView: TCustomTreeView;
  503.     procedure InternalMove(ParentNode, Node: TTreeNode; HItem: HTreeItem;
  504.       AddMode: TAddMode);
  505.     function IsEqual(Node: TTreeNode): Boolean;
  506.     function IsNodeVisible: Boolean;
  507.     procedure ReadData(Stream: TStream; Info: PNodeInfo);
  508.     procedure SetChildren(Value: Boolean);
  509.     procedure SetCut(Value: Boolean);
  510.     procedure SetData(Value: Pointer);
  511.     procedure SetDropTarget(Value: Boolean);
  512.     procedure SetItem(Index: Integer; Value: TTreeNode);
  513.     procedure SetExpanded(Value: Boolean);
  514.     procedure SetFocused(Value: Boolean);
  515.     procedure SetImageIndex(Value: Integer);
  516.     procedure SetOverlayIndex(Value: Integer);
  517.     procedure SetSelectedIndex(Value: Integer);
  518.     procedure SetSelected(Value: Boolean);
  519.     procedure SetStateIndex(Value: Integer);
  520.     procedure SetText(const S: string);
  521.     procedure WriteData(Stream: TStream; Info: PNodeInfo);
  522.   public
  523.     constructor Create(AOwner: TTreeNodes);
  524.     destructor Destroy; override;
  525.     function AlphaSort: Boolean;
  526.     procedure Assign(Source: TPersistent); override;
  527.     procedure Collapse(Recurse: Boolean);
  528.     function CustomSort(SortProc: TTVCompare; Data: Longint): Boolean;
  529.     procedure Delete;
  530.     procedure DeleteChildren;
  531.     function DisplayRect(TextOnly: Boolean): TRect;
  532.     function EditText: Boolean;
  533.     procedure EndEdit(Cancel: Boolean);
  534.     procedure Expand(Recurse: Boolean);
  535.     function GetFirstChild: TTreeNode;
  536.     function GetHandle: HWND;
  537.     function GetLastChild: TTreeNode;
  538.     function GetNext: TTreeNode;
  539.     function GetNextChild(Value: TTreeNode): TTreeNode;
  540.     function GetNextSibling: TTreeNode;
  541.     function GetNextVisible: TTreeNode;
  542.     function GetPrev: TTreeNode;
  543.     function GetPrevChild(Value: TTreeNode): TTreeNode;
  544.     function GetPrevSibling: TTreeNode;
  545.     function GetPrevVisible: TTreeNode;
  546.     function HasAsParent(Value: TTreeNode): Boolean;
  547.     function IndexOf(Value: TTreeNode): Integer;
  548.     procedure MakeVisible;
  549.     procedure MoveTo(Destination: TTreeNode; Mode: TNodeAttachMode);
  550.     property AbsoluteIndex: Integer read GetAbsoluteIndex;
  551.     property Count: Integer read GetCount;
  552.     property Cut: Boolean read GetCut write SetCut;
  553.     property Data: Pointer read FData write SetData;
  554.     property Deleting: Boolean read FDeleting;
  555.     property Focused: Boolean read GetFocused write SetFocused;
  556.     property DropTarget: Boolean read GetDropTarget write SetDropTarget;
  557.     property Selected: Boolean read GetSelected write SetSelected;
  558.     property Expanded: Boolean read GetExpanded write SetExpanded;
  559.     property Handle: HWND read GetHandle;
  560.     property HasChildren: Boolean read GetChildren write SetChildren;
  561.     property ImageIndex: Integer read FImageIndex write SetImageIndex;
  562.     property Index: Integer read GetIndex;
  563.     property IsVisible: Boolean read IsNodeVisible;
  564.     property Item[Index: Integer]: TTreeNode read GetItem write SetItem; default;
  565.     property ItemId: HTreeItem read FItemId;
  566.     property Level: Integer read GetLevel;
  567.     property OverlayIndex: Integer read FOverlayIndex write SetOverlayIndex;
  568.     property Owner: TTreeNodes read FOwner;
  569.     property Parent: TTreeNode read GetParent;
  570.     property SelectedIndex: Integer read FSelectedIndex write SetSelectedIndex;
  571.     property StateIndex: Integer read FStateIndex write SetStateIndex;
  572.     property Text: string read FText write SetText;
  573.     property TreeView: TCustomTreeView read GetTreeView;
  574.   end;
  575.  
  576. { TTreeNodes }
  577.  
  578.   TTreeNodes = class(TPersistent)
  579.   private
  580.     FOwner: TCustomTreeView;
  581.     FUpdateCount: Integer;
  582.     procedure AddedNode(Value: TTreeNode);
  583.     function GetHandle: HWND;
  584.     function GetNodeFromIndex(Index: Integer): TTreeNode;
  585.     procedure ReadData(Stream: TStream);
  586.     procedure Repaint(Node: TTreeNode);
  587.     procedure WriteData(Stream: TStream);
  588.   protected
  589.     function AddItem(Parent, Target: HTreeItem; const Item: TTVItem;
  590.       AddMode: TAddMode): HTreeItem;
  591.     function InternalAddObject(Node: TTreeNode; const S: string;
  592.       Ptr: Pointer; AddMode: TAddMode): TTreeNode;
  593.     procedure DefineProperties(Filer: TFiler); override;
  594.     function CreateItem(Node: TTreeNode): TTVItem;
  595.     function GetCount: Integer;
  596.     procedure SetItem(Index: Integer; Value: TTreeNode);
  597.     procedure SetUpdateState(Updating: Boolean);
  598.   public
  599.     constructor Create(AOwner: TCustomTreeView);
  600.     destructor Destroy; override;
  601.     function AddChildFirst(Node: TTreeNode; const S: string): TTreeNode;
  602.     function AddChild(Node: TTreeNode; const S: string): TTreeNode;
  603.     function AddChildObjectFirst(Node: TTreeNode; const S: string;
  604.       Ptr: Pointer): TTreeNode;
  605.     function AddChildObject(Node: TTreeNode; const S: string;
  606.       Ptr: Pointer): TTreeNode;
  607.     function AddFirst(Node: TTreeNode; const S: string): TTreeNode;
  608.     function Add(Node: TTreeNode; const S: string): TTreeNode;
  609.     function AddObjectFirst(Node: TTreeNode; const S: string;
  610.       Ptr: Pointer): TTreeNode;
  611.     function AddObject(Node: TTreeNode; const S: string;
  612.       Ptr: Pointer): TTreeNode;
  613.     procedure Assign(Source: TPersistent); override;
  614.     procedure BeginUpdate;
  615.     procedure Clear;
  616.     procedure Delete(Node: TTreeNode);
  617.     procedure EndUpdate;
  618.     function GetFirstNode: TTreeNode;
  619.     function GetNode(ItemId: HTreeItem): TTreeNode;
  620.     function Insert(Node: TTreeNode; const S: string): TTreeNode;
  621.     function InsertObject(Node: TTreeNode; const S: string;
  622.       Ptr: Pointer): TTreeNode;
  623.     property Count: Integer read GetCount;
  624.     property Handle: HWND read GetHandle;
  625.     property Item[Index: Integer]: TTreeNode read GetNodeFromIndex; default;
  626.     property Owner: TCustomTreeView read FOwner;
  627.   end;
  628.  
  629. { TCustomTreeView }
  630.  
  631.   THitTest = (htAbove, htBelow, htNowhere, htOnItem, htOnButton,
  632.     htOnIcon, htOnIndent, htOnLabel, htOnRight,
  633.     htOnStateIcon, htToLeft, htToRight);
  634.   THitTests = set of THitTest;
  635.   ETreeViewError = class(Exception);
  636.  
  637.   TTVChangingEvent = procedure(Sender: TObject; Node: TTreeNode;
  638.     var AllowChange: Boolean) of object;
  639.   TTVChangedEvent = procedure(Sender: TObject; Node: TTreeNode) of object;
  640.   TTVEditingEvent = procedure(Sender: TObject; Node: TTreeNode;
  641.     var AllowEdit: Boolean) of object;
  642.   TTVEditedEvent = procedure(Sender: TObject; Node: TTreeNode; var S: string) of object;
  643.   TTVExpandingEvent = procedure(Sender: TObject; Node: TTreeNode;
  644.     var AllowExpansion: Boolean) of object;
  645.   TTVCollapsingEvent = procedure(Sender: TObject; Node: TTreeNode;
  646.     var AllowCollapse: Boolean) of object;
  647.   TTVExpandedEvent = procedure(Sender: TObject; Node: TTreeNode) of object;
  648.   TTVCompareEvent = procedure(Sender: TObject; Node1, Node2: TTreeNode;
  649.     Data: Integer; var Compare: Integer) of object;
  650.  
  651.   TSortType = (stNone, stData, stText, stBoth);
  652.  
  653.   TCustomTreeView = class(TWinControl)
  654.   private
  655.     FShowLines: Boolean;
  656.     FShowRoot: Boolean;
  657.     FShowButtons: Boolean;
  658.     FBorderStyle: TBorderStyle;
  659.     FReadOnly: Boolean;
  660.     FImages: TImageList;
  661.     FStateImages: TImageList;
  662.     FImageChangeLink: TChangeLink;
  663.     FStateChangeLink: TChangeLink;
  664.     FDragImage: TImageList;
  665.     FTreeNodes: TTreeNodes;
  666.     FSortType: TSortType;
  667.     FSaveItems: TStringList;
  668.     FSaveTopIndex: Integer;
  669.     FSaveIndex: Integer;
  670.     FSaveIndent: Integer;
  671.     FHideSelection: Boolean;
  672.     FMemStream: TMemoryStream;
  673.     FEditInstance: Pointer;
  674.     FDefEditProc: Pointer;
  675.     FEditHandle: HWND;
  676.     FDragged: Boolean;
  677.     FRClickNode: TTreeNode;
  678.     FLastDropTarget: TTreeNode;
  679.     FDragNode: TTreeNode;
  680.     FManualNotify: Boolean;
  681.     FRightClickSelect: Boolean; 
  682.     FSavedSort: TSortType;
  683.     FOnEditing: TTVEditingEvent;
  684.     FOnEdited: TTVEditedEvent;
  685.     FOnExpanded: TTVExpandedEvent;
  686.     FOnExpanding: TTVExpandingEvent;
  687.     FOnCollapsed: TTVExpandedEvent;
  688.     FOnCollapsing: TTVCollapsingEvent;
  689.     FOnChanging: TTVChangingEvent;
  690.     FOnChange: TTVChangedEvent;
  691.     FOnCompare: TTVCompareEvent;
  692.     FOnDeletion: TTVExpandedEvent;
  693.     FOnGetImageIndex: TTVExpandedEvent;
  694.     FOnGetSelectedIndex: TTVExpandedEvent;
  695.     procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED;
  696.     procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
  697.     procedure CMDrag(var Message: TCMDrag); message CM_DRAG;
  698.     procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY;
  699.     procedure EditWndProc(var Message: TMessage);
  700.     procedure DoDragOver(Source: TDragObject; X, Y: Integer);
  701.     procedure GetImageIndex(Node: TTreeNode);
  702.     procedure GetSelectedIndex(Node: TTreeNode);
  703.     function GetDropTarget: TTreeNode;
  704.     function GetIndent: Integer;
  705.     function GetNodeFromItem(const Item: TTVItem): TTreeNode;
  706.     function GetSelection: TTreeNode;
  707.     function GetTopItem: TTreeNode;
  708.     procedure ImageListChange(Sender: TObject);
  709.     procedure SetBorderStyle(Value: TBorderStyle);
  710.     procedure SetButtonStyle(Value: Boolean);
  711.     procedure SetDropTarget(Value: TTreeNode);
  712.     procedure SetHideSelection(Value: Boolean);
  713.     procedure SetImageList(Value: HImageList; Flags: Integer);
  714.     procedure SetIndent(Value: Integer);
  715.     procedure SetImages(Value: TImageList);
  716.     procedure SetLineStyle(Value: Boolean);
  717.     procedure SetReadOnly(Value: Boolean);
  718.     procedure SetRootStyle(Value: Boolean);
  719.     procedure SetSelection(Value: TTreeNode);
  720.     procedure SetSortType(Value: TSortType);
  721.     procedure SetStateImages(Value: TImageList);
  722.     procedure SetStyle(Value: Integer; UseStyle: Boolean);
  723.     procedure SetTreeNodes(Value: TTreeNodes);
  724.     procedure SetTopItem(Value: TTreeNode);
  725.     procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
  726.     procedure WMRButtonDown(var Message: TWMRButtonDown); message WM_RBUTTONDOWN;
  727.     procedure WMRButtonUp(var Message: TWMRButtonUp); message WM_RBUTTONUP;
  728.   protected
  729.     function CanEdit(Node: TTreeNode): Boolean; dynamic;
  730.     function CanChange(Node: TTreeNode): Boolean; dynamic;
  731.     function CanCollapse(Node: TTreeNode): Boolean; dynamic;
  732.     function CanExpand(Node: TTreeNode): Boolean; dynamic;
  733.     procedure Change(Node: TTreeNode); dynamic;
  734.     procedure Collapse(Node: TTreeNode); dynamic;
  735.     function CreateNode: TTreeNode; virtual;
  736.     procedure CreateParams(var Params: TCreateParams); override;
  737.     procedure CreateWnd; override;
  738.     procedure DestroyWnd; override;
  739.     procedure DoEndDrag(Target: TObject; X, Y: Integer); override;
  740.     procedure DoStartDrag(var DragObject: TDragObject); override;
  741.     procedure Edit(const Item: TTVItem); dynamic;
  742.     procedure Expand(Node: TTreeNode); dynamic;
  743.     function GetDragImages: TCustomImageList; override;
  744.     procedure Loaded; override;
  745.     procedure Notification(AComponent: TComponent;
  746.       Operation: TOperation); override;
  747.     procedure SetDragMode(Value: TDragMode); override;
  748.     procedure WndProc(var Message: TMessage); override;
  749.     property OnEditing: TTVEditingEvent read FOnEditing write FOnEditing;
  750.     property OnEdited: TTVEditedEvent read FOnEdited write FOnEdited;
  751.     property OnExpanding: TTVExpandingEvent read FOnExpanding write FOnExpanding;
  752.     property OnExpanded: TTVExpandedEvent read FOnExpanded write FOnExpanded;
  753.     property OnCollapsing: TTVCollapsingEvent read FOnCollapsing write FOnCollapsing;
  754.     property OnCollapsed: TTVExpandedEvent read FOnCollapsed write FOnCollapsed;
  755.     property OnChanging: TTVChangingEvent read FOnChanging write FOnChanging;
  756.     property OnChange: TTVChangedEvent read FOnChange write FOnChange;
  757.     property OnCompare: TTVCompareEvent read FOnCompare write FOnCompare;
  758.     property OnDeletion: TTVExpandedEvent read FOnDeletion write FOnDeletion;
  759.     property OnGetImageIndex: TTVExpandedEvent read FOnGetImageIndex write FOnGetImageIndex;
  760.     property OnGetSelectedIndex: TTVExpandedEvent read FOnGetSelectedIndex write FOnGetSelectedIndex;
  761.     property ShowButtons: Boolean read FShowButtons write SetButtonStyle default True;
  762.     property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;
  763.     property ShowLines: Boolean read FShowLines write SetLineStyle default True;
  764.     property ShowRoot: Boolean read FShowRoot write SetRootStyle default True;
  765.     property ReadOnly: Boolean read FReadOnly write SetReadOnly default False;
  766.     property RightClickSelect: Boolean read FRightClickSelect write FRightClickSelect default False;
  767.     property Indent: Integer read GetIndent write SetIndent;
  768.     property Items: TTreeNodes read FTreeNodes write SetTreeNodes;
  769.     property SortType: TSortType read FSortType write SetSortType default stNone;
  770.     property HideSelection: Boolean read FHideSelection write SetHideSelection default True;
  771.     property Images: TImageList read FImages write SetImages;
  772.     property StateImages: TImageList read FStateImages write SetStateImages;
  773.   public
  774.     constructor Create(AOwner: TComponent); override;
  775.     destructor Destroy; override;
  776.     function AlphaSort: Boolean;
  777.     function CustomSort(SortProc: TTVCompare; Data: Longint): Boolean;
  778.     procedure FullCollapse;
  779.     procedure FullExpand;
  780.     function GetHitTestInfoAt(X, Y: Integer): THitTests;
  781.     function GetNodeAt(X, Y: Integer): TTreeNode;
  782.     function IsEditing: Boolean;
  783.     procedure LoadFromFile(const FileName: string);
  784.     procedure LoadFromStream(Stream: TStream);
  785.     procedure SaveToFile(const FileName: string);
  786.     procedure SaveToStream(Stream: TStream);
  787.     property DropTarget: TTreeNode read GetDropTarget write SetDropTarget;
  788.     property Selected: TTreeNode read GetSelection write SetSelection;
  789.     property TopItem: TTreeNode read GetTopItem write SetTopItem;
  790.   end;
  791.  
  792.   TTreeView = class(TCustomTreeView)
  793.   published
  794.     property ShowButtons;
  795.     property BorderStyle;
  796.     property DragCursor;
  797.     property ShowLines;
  798.     property ShowRoot;
  799.     property ReadOnly;
  800.     property RightClickSelect;
  801.     property DragMode;
  802.     property HideSelection;
  803.     property Indent;
  804.     property Items;
  805.     property OnEditing;
  806.     property OnEdited;
  807.     property OnExpanding;
  808.     property OnExpanded;
  809.     property OnCollapsing;
  810.     property OnCompare;
  811.     property OnCollapsed;
  812.     property OnChanging;
  813.     property OnChange;
  814.     property OnDeletion;
  815.     property OnGetImageIndex;
  816.     property OnGetSelectedIndex;
  817.     property Align;
  818.     property Enabled;
  819.     property Font;
  820.     property Color;
  821.     property ParentColor default False;
  822.     property ParentCtl3D;
  823.     property Ctl3D;
  824.     property SortType;
  825.     property TabOrder;
  826.     property TabStop default True;
  827.     property Visible;
  828.     property OnClick;
  829.     property OnEnter;
  830.     property OnExit;
  831.     property OnDragDrop;
  832.     property OnDragOver;
  833.     property OnStartDrag;
  834.     property OnEndDrag;
  835.     property OnMouseDown;
  836.     property OnMouseMove;
  837.     property OnMouseUp;
  838.     property OnDblClick;
  839.     property OnKeyDown;
  840.     property OnKeyPress;
  841.     property OnKeyUp;
  842.     property PopupMenu;
  843.     property ParentFont;
  844.     property ParentShowHint;
  845.     property ShowHint;
  846.     property Images;
  847.     property StateImages;
  848.   end;
  849.  
  850. { TTrackBar }
  851.  
  852.   TTrackBarOrientation = (trHorizontal, trVertical);
  853.   TTickMark = (tmBottomRight, tmTopLeft, tmBoth);
  854.   TTickStyle = (tsNone, tsAuto, tsManual);
  855.  
  856.   TTrackBar = class(TWinControl)
  857.   private
  858.     FOrientation: TTrackBarOrientation;
  859.     FTickMarks: TTickMark;
  860.     FTickStyle: TTickStyle;
  861.     FLineSize: Integer;
  862.     FPageSize: Integer;
  863.     FMin: Integer;
  864.     FMax: Integer;
  865.     FFrequency: Integer;
  866.     FPosition: Integer;
  867.     FSelStart: Integer;
  868.     FSelEnd: Integer;
  869.     FOnChange: TNotifyEvent;
  870.     procedure SetOrientation(Value: TTrackBarOrientation);
  871.     procedure SetParams(APosition, AMin, AMax: Integer);
  872.     procedure SetPosition(Value: Integer);
  873.     procedure SetMin(Value: Integer);
  874.     procedure SetMax(Value: Integer);
  875.     procedure SetFrequency(Value: Integer);
  876.     procedure SetTickStyle(Value: TTickStyle);
  877.     procedure SetTickMarks(Value: TTickMark);
  878.     procedure SetLineSize(Value: Integer);
  879.     procedure SetPageSize(Value: Integer);
  880.     procedure SetSelStart(Value: Integer);
  881.     procedure SetSelEnd(Value: Integer);
  882.     procedure UpdateSelection;
  883.     procedure CNHScroll(var Message: TWMHScroll); message CN_HSCROLL;
  884.     procedure CNVScroll(var Message: TWMVScroll); message CN_VSCROLL;
  885.   protected
  886.     procedure CreateParams(var Params: TCreateParams); override;
  887.     procedure CreateWnd; override;
  888.     procedure DestroyWnd; override;
  889.   public
  890.     constructor Create(AOwner: TComponent); override;
  891.     procedure SetTick(Value: Integer);
  892.   published
  893.     property Ctl3D;
  894.     property DragCursor;
  895.     property DragMode;
  896.     property Enabled;
  897.     property LineSize: Integer read FLineSize write SetLineSize default 1;
  898.     property Max: Integer read FMax write SetMax default 10;
  899.     property Min: Integer read FMin write SetMin default 0;
  900.     property Orientation: TTrackBarOrientation read FOrientation write SetOrientation;
  901.     property ParentCtl3D;
  902.     property ParentShowHint;
  903.     property PageSize: Integer read FPageSize write SetPageSize default 2;
  904.     property PopupMenu;
  905.     property Frequency: Integer read FFrequency write SetFrequency;
  906.     property Position: Integer read FPosition write SetPosition;
  907.     property SelEnd: Integer read FSelEnd write SetSelEnd;
  908.     property SelStart: Integer read FSelStart write SetSelStart;
  909.     property ShowHint;
  910.     property TabOrder;
  911.     property TabStop default True;
  912.     property TickMarks: TTickMark read FTickMarks write SetTickMarks;
  913.     property TickStyle: TTickStyle read FTickStyle write SetTickStyle;
  914.     property Visible;
  915.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  916.     property OnDragDrop;
  917.     property OnDragOver;
  918.     property OnEndDrag;
  919.     property OnEnter;
  920.     property OnExit;
  921.     property OnKeyDown;
  922.     property OnKeyPress;
  923.     property OnKeyUp;
  924.     property OnStartDrag;
  925.   end;
  926.  
  927. { TProgressBar }
  928.  
  929.   TProgressRange = Integer; // for backward compatibility
  930.  
  931.   TProgressBar = class(TWinControl)
  932.   private
  933.     FMin: Integer;
  934.     FMax: Integer;
  935.     FStep: Integer;
  936.     FPosition: Integer;
  937.     function GetMin: Integer;
  938.     function GetMax: Integer;
  939.     function GetPosition: Integer;
  940.     procedure SetParams(AMin, AMax: Integer);
  941.     procedure SetMin(Value: Integer);
  942.     procedure SetMax(Value: Integer);
  943.     procedure SetPosition(Value: Integer);
  944.     procedure SetStep(Value: Integer);
  945.   protected
  946.     procedure CreateParams(var Params: TCreateParams); override;
  947.     procedure CreateWnd; override;
  948.   public
  949.     constructor Create(AOwner: TComponent); override;
  950.     procedure StepIt;
  951.     procedure StepBy(Delta: Integer);
  952.   published
  953.     property Align;
  954.     property DragCursor;
  955.     property DragMode;
  956.     property Enabled;
  957.     property Hint;
  958.     property Min: Integer read GetMin write SetMin;
  959.     property Max: Integer read GetMax write SetMax;
  960.     property ParentShowHint;
  961.     property PopupMenu;
  962.     property Position: Integer read GetPosition write SetPosition default 0;
  963.     property Step: Integer read FStep write SetStep default 10;
  964.     property ShowHint;
  965.     property TabOrder;
  966.     property TabStop;
  967.     property Visible;
  968.     property OnDragDrop;
  969.     property OnDragOver;
  970.     property OnEndDrag;
  971.     property OnEnter;
  972.     property OnExit;
  973.     property OnMouseDown;
  974.     property OnMouseMove;
  975.     property OnMouseUp;
  976.     property OnStartDrag;
  977.   end;
  978.  
  979. { TTextAttributes }
  980.  
  981.   TCustomRichEdit = class;
  982.  
  983.   TAttributeType = (atSelected, atDefaultText);
  984.   TConsistentAttribute = (caBold, caColor, caFace, caItalic,
  985.     caSize, caStrikeOut, caUnderline, caProtected);
  986.   TConsistentAttributes = set of TConsistentAttribute;
  987.  
  988.   TTextAttributes = class(TPersistent)
  989.   private
  990.     RichEdit: TCustomRichEdit;
  991.     FType: TAttributeType;
  992.     procedure GetAttributes(var Format: TCharFormat);
  993.     function GetColor: TColor;
  994.     function GetConsistentAttributes: TConsistentAttributes;
  995.     function GetHeight: Integer;
  996.     function GetName: TFontName;
  997.     function GetPitch: TFontPitch;
  998.     function GetProtected: Boolean;
  999.     function GetSize: Integer;
  1000.     function GetStyle: TFontStyles;
  1001.     procedure SetAttributes(var Format: TCharFormat);
  1002.     procedure SetColor(Value: TColor);
  1003.     procedure SetHeight(Value: Integer);
  1004.     procedure SetName(Value: TFontName);
  1005.     procedure SetPitch(Value: TFontPitch);
  1006.     procedure SetProtected(Value: Boolean);
  1007.     procedure SetSize(Value: Integer);
  1008.     procedure SetStyle(Value: TFontStyles);
  1009.   protected
  1010.     procedure InitFormat(var Format: TCharFormat);
  1011.     procedure AssignTo(Dest: TPersistent); override;
  1012.   public
  1013.     constructor Create(AOwner: TCustomRichEdit; AttributeType: TAttributeType);
  1014.     procedure Assign(Source: TPersistent); override;
  1015.     property Color: TColor read GetColor write SetColor;
  1016.     property ConsistentAttributes: TConsistentAttributes read GetConsistentAttributes;
  1017.     property Name: TFontName read GetName write SetName;
  1018.     property Pitch: TFontPitch read GetPitch write SetPitch;
  1019.     property Protected: Boolean read GetProtected write SetProtected;
  1020.     property Size: Integer read GetSize write SetSize;
  1021.     property Style: TFontStyles read GetStyle write SetStyle;
  1022.     property Height: Integer read GetHeight write SetHeight;
  1023.   end;
  1024.  
  1025. { TParaAttributes }
  1026.  
  1027.   TNumberingStyle = (nsNone, nsBullet);
  1028.  
  1029.   TParaAttributes = class(TPersistent)
  1030.   private
  1031.     RichEdit: TCustomRichEdit;
  1032.     procedure GetAttributes(var Paragraph: TParaFormat);
  1033.     function GetAlignment: TAlignment;
  1034.     function GetFirstIndent: Longint;
  1035.     function GetLeftIndent: Longint;
  1036.     function GetRightIndent: Longint;
  1037.     function GetNumbering: TNumberingStyle;
  1038.     function GetTab(Index: Byte): Longint;
  1039.     function GetTabCount: Integer;
  1040.     procedure InitPara(var Paragraph: TParaFormat);
  1041.     procedure SetAlignment(Value: TAlignment);
  1042.     procedure SetAttributes(var Paragraph: TParaFormat);
  1043.     procedure SetFirstIndent(Value: Longint);
  1044.     procedure SetLeftIndent(Value: Longint);
  1045.     procedure SetRightIndent(Value: Longint);
  1046.     procedure SetNumbering(Value: TNumberingStyle);
  1047.     procedure SetTab(Index: Byte; Value: Longint);
  1048.     procedure SetTabCount(Value: Integer);
  1049.   public
  1050.     constructor Create(AOwner: TCustomRichEdit);
  1051.     procedure Assign(Source: TPersistent); override;
  1052.     property Alignment: TAlignment read GetAlignment write SetAlignment;
  1053.     property FirstIndent: Longint read GetFirstIndent write SetFirstIndent;
  1054.     property LeftIndent: Longint read GetLeftIndent write SetLeftIndent;
  1055.     property Numbering: TNumberingStyle read GetNumbering write SetNumbering;
  1056.     property RightIndent: Longint read GetRightIndent write SetRightIndent;
  1057.     property Tab[Index: Byte]: Longint read GetTab write SetTab;
  1058.     property TabCount: Integer read GetTabCount write SetTabCount;
  1059.   end;
  1060.  
  1061. { TCustomRichEdit }
  1062.  
  1063.   TRichEditResizeEvent = procedure(Sender: TObject; Rect: TRect) of object;
  1064.   TRichEditProtectChange = procedure(Sender: TObject;
  1065.     StartPos, EndPos: Integer; var AllowChange: Boolean) of object;
  1066.   TRichEditSaveClipboard = procedure(Sender: TObject;
  1067.     NumObjects, NumChars: Integer; var SaveClipboard: Boolean) of object;
  1068.   TSearchType = (stWholeWord, stMatchCase);
  1069.   TSearchTypes = set of TSearchType;
  1070.  
  1071.   TConversion = class(TObject)
  1072.   public
  1073.     function ConvertReadStream(Stream: TStream; Buffer: PChar; BufSize: Integer): Integer; virtual;
  1074.     function ConvertWriteStream(Stream: TStream; Buffer: PChar; BufSize: Integer): Integer; virtual;
  1075.   end;
  1076.  
  1077.   TConversionClass = class of TConversion;
  1078.  
  1079.   PConversionFormat = ^TConversionFormat;
  1080.   TConversionFormat = record
  1081.     ConversionClass: TConversionClass;
  1082.     Extension: string;
  1083.     Next: PConversionFormat;
  1084.   end;
  1085.  
  1086.   PRichEditStreamInfo = ^TRichEditStreamInfo;
  1087.   TRichEditStreamInfo = record
  1088.     Converter: TConversion;
  1089.     Stream: TStream;
  1090.   end;
  1091.  
  1092.   TCustomRichEdit = class(TCustomMemo)
  1093.   private
  1094.     FLibHandle: THandle;
  1095.     FHideScrollBars: Boolean;
  1096.     FSelAttributes: TTextAttributes;
  1097.     FDefAttributes: TTextAttributes;
  1098.     FParagraph: TParaAttributes;
  1099.     FScreenLogPixels: Integer;
  1100.     FRichEditStrings: TStrings;
  1101.     FMemStream: TMemoryStream;
  1102.     FOnSelChange: TNotifyEvent;
  1103.     FHideSelection: Boolean;
  1104.     FModified: Boolean;
  1105.     FDefaultConverter: TConversionClass;
  1106.     FOnResizeRequest: TRichEditResizeEvent;
  1107.     FOnProtectChange: TRichEditProtectChange;
  1108.     FOnSaveClipboard: TRichEditSaveClipboard;
  1109.     FPageRect: TRect;
  1110.     procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED;
  1111.     procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
  1112.     procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY;
  1113.     function GetPlainText: Boolean;
  1114.     function ProtectChange(StartPos, EndPos: Integer): Boolean;
  1115.     function SaveClipboard(NumObj, NumChars: Integer): Boolean;
  1116.     procedure SetHideScrollBars(Value: Boolean);
  1117.     procedure SetHideSelection(Value: Boolean);
  1118.     procedure SetPlainText(Value: Boolean);
  1119.     procedure SetRichEditStrings(Value: TStrings);
  1120.     procedure SetDefAttributes(Value: TTextAttributes);
  1121.     procedure SetSelAttributes(Value: TTextAttributes);
  1122.     procedure WMNCDestroy(var Message: TWMNCDestroy); message WM_NCDESTROY;
  1123.     procedure WMSetCursor(var Message: TWMSetCursor); message WM_SETCURSOR;
  1124.     procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
  1125.     procedure WMSetFont(var Message: TWMSetFont); message WM_SETFONT;
  1126.   protected
  1127.     procedure CreateParams(var Params: TCreateParams); override;
  1128.     procedure CreateWnd; override;
  1129.     procedure DestroyWnd; override;
  1130.     procedure RequestSize(const Rect: TRect); virtual;
  1131.     procedure SelectionChange; dynamic;
  1132.     procedure DoSetMaxLength(Value: Integer); override;
  1133.     function GetSelLength: Integer; override;
  1134.     function GetSelStart: Integer; override;
  1135.     function GetSelText: string; override;
  1136.     procedure SetSelLength(Value: Integer); override;
  1137.     procedure SetSelStart(Value: Integer); override;
  1138.     property HideSelection: Boolean read FHideSelection write SetHideSelection default True;
  1139.     property HideScrollBars: Boolean read FHideScrollBars
  1140.       write SetHideScrollBars default True;
  1141.     property Lines: TStrings read FRichEditStrings write SetRichEditStrings;
  1142.     property OnSaveClipboard: TRichEditSaveClipboard read FOnSaveClipboard
  1143.       write FOnSaveClipboard;
  1144.     property OnSelectionChange: TNotifyEvent read FOnSelChange write FOnSelChange;
  1145.     property OnProtectChange: TRichEditProtectChange read FOnProtectChange
  1146.       write FOnProtectChange;
  1147.     property OnResizeRequest: TRichEditResizeEvent read FOnResizeRequest
  1148.       write FOnResizeRequest;
  1149.     property PlainText: Boolean read GetPlainText write SetPlainText default False;
  1150.   public
  1151.     constructor Create(AOwner: TComponent); override;
  1152.     destructor Destroy; override;
  1153.     procedure Clear; override;
  1154.     function FindText(const SearchStr: string;
  1155.       StartPos, Length: Integer; Options: TSearchTypes): Integer;
  1156.     function GetSelTextBuf(Buffer: PChar; BufSize: Integer): Integer; override;
  1157.     procedure Print(const Caption: string);
  1158.     class procedure RegisterConversionFormat(const AExtension: string;
  1159.       AConversionClass: TConversionClass);
  1160.     property DefaultConverter: TConversionClass
  1161.       read FDefaultConverter write FDefaultConverter;
  1162.     property DefAttributes: TTextAttributes read FDefAttributes write SetDefAttributes;
  1163.     property SelAttributes: TTextAttributes read FSelAttributes write SetSelAttributes;
  1164.     property PageRect: TRect read FPageRect write FPageRect;
  1165.     property Paragraph: TParaAttributes read FParagraph;
  1166.   end;
  1167.  
  1168.   TRichEdit = class(TCustomRichEdit)
  1169.   published
  1170.     property Align;
  1171.     property Alignment;
  1172.     property BorderStyle;
  1173.     property Color;
  1174.     property Ctl3D;
  1175.     property DragCursor;
  1176.     property DragMode;
  1177.     property Enabled;
  1178.     property Font;
  1179.     property HideSelection;
  1180.     property HideScrollBars;
  1181.     property ImeMode;
  1182.     property ImeName;
  1183.     property Lines;
  1184.     property MaxLength;
  1185.     property ParentColor;
  1186.     property ParentCtl3D;
  1187.     property ParentFont;
  1188.     property ParentShowHint;
  1189.     property PlainText;
  1190.     property PopupMenu;
  1191.     property ReadOnly;
  1192.     property ScrollBars;
  1193.     property ShowHint;
  1194.     property TabOrder;
  1195.     property TabStop default True;
  1196.     property Visible;
  1197.     property WantTabs;
  1198.     property WantReturns;
  1199.     property WordWrap;
  1200.     property OnChange;
  1201.     property OnDragDrop;
  1202.     property OnDragOver;
  1203.     property OnEndDrag;
  1204.     property OnEnter;
  1205.     property OnExit;
  1206.     property OnKeyDown;
  1207.     property OnKeyPress;
  1208.     property OnKeyUp;
  1209.     property OnMouseDown;
  1210.     property OnMouseMove;
  1211.     property OnMouseUp;
  1212.     property OnResizeRequest;
  1213.     property OnSelectionChange;
  1214.     property OnStartDrag;
  1215.     property OnProtectChange;
  1216.     property OnSaveClipboard;
  1217.   end;
  1218.  
  1219. { TUpDown }
  1220.  
  1221.   TUDAlignButton = (udLeft, udRight);
  1222.   TUDOrientation = (udHorizontal, udVertical);
  1223.   TUDBtnType = (btNext, btPrev);
  1224.   TUDClickEvent = procedure (Sender: TObject; Button: TUDBtnType) of object;
  1225.   TUDChangingEvent = procedure (Sender: TObject; var AllowChange: Boolean) of object;
  1226.  
  1227.   TCustomUpDown = class(TWinControl)
  1228.   private
  1229.     FArrowKeys: Boolean;
  1230.     FAssociate: TWinControl;
  1231.     FMin: SmallInt;
  1232.     FMax: SmallInt;
  1233.     FIncrement: Integer;
  1234.     FPosition: SmallInt;
  1235.     FThousands: Boolean;
  1236.     FWrap: Boolean;
  1237.     FOnClick: TUDClickEvent;
  1238.     FAlignButton: TUDAlignButton;
  1239.     FOrientation: TUDOrientation;
  1240.     FOnChanging: TUDChangingEvent;
  1241.     procedure UndoAutoResizing(Value: TWinControl);
  1242.     procedure SetAssociate(Value: TWinControl);
  1243.     function GetPosition: SmallInt;
  1244.     procedure SetMin(Value: SmallInt);
  1245.     procedure SetMax(Value: SmallInt);
  1246.     procedure SetIncrement(Value: Integer);
  1247.     procedure SetPosition(Value: SmallInt);
  1248.     procedure SetAlignButton(Value: TUDAlignButton);
  1249.     procedure SetOrientation(Value: TUDOrientation);
  1250.     procedure SetArrowKeys(Value: Boolean);
  1251.     procedure SetThousands(Value: Boolean);
  1252.     procedure SetWrap(Value: Boolean);
  1253.     procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY;
  1254.     procedure WMHScroll(var Message: TWMHScroll); message CN_HSCROLL;
  1255.     procedure WMSize(var Message: TWMSize); message WM_SIZE;
  1256.     procedure WMVScroll(var Message: TWMVScroll); message CN_VSCROLL;
  1257.   protected
  1258.     function CanChange: Boolean;
  1259.     procedure CreateParams(var Params: TCreateParams); override;
  1260.     procedure CreateWnd; override;
  1261.     procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  1262.     procedure Click(Button: TUDBtnType); dynamic;
  1263.     property AlignButton: TUDAlignButton read FAlignButton write SetAlignButton default udRight;
  1264.     property ArrowKeys: Boolean read FArrowKeys write SetArrowKeys default True;
  1265.     property Associate: TWinControl read FAssociate write SetAssociate;
  1266.     property Min: SmallInt read FMin write SetMin;
  1267.     property Max: SmallInt read FMax write SetMax default 100;
  1268.     property Increment: Integer read FIncrement write SetIncrement default 1;
  1269.     property Orientation: TUDOrientation read FOrientation write SetOrientation default udVertical;
  1270.     property Position: SmallInt read GetPosition write SetPosition;
  1271.     property Thousands: Boolean read FThousands write SetThousands default True;
  1272.     property Wrap: Boolean read FWrap write SetWrap;
  1273.     property OnChanging: TUDChangingEvent read FOnChanging write FOnChanging;
  1274.     property OnClick: TUDClickEvent read FOnClick write FOnClick;
  1275.   public
  1276.     constructor Create(AOwner: TComponent); override;
  1277.   end;
  1278.  
  1279.   TUpDown = class(TCustomUpDown)
  1280.   published
  1281.     property AlignButton;
  1282.     property Associate;
  1283.     property ArrowKeys;
  1284.     property Enabled;
  1285.     property Hint;
  1286.     property Min;
  1287.     property Max;
  1288.     property Increment;
  1289.     property Orientation;
  1290.     property ParentShowHint;
  1291.     property PopupMenu;
  1292.     property Position;
  1293.     property ShowHint;
  1294.     property TabOrder;
  1295.     property TabStop;
  1296.     property Thousands;
  1297.     property Visible;
  1298.     property Wrap;
  1299.     property OnChanging;
  1300.     property OnClick;
  1301.     property OnEnter;
  1302.     property OnExit;
  1303.     property OnMouseDown;
  1304.     property OnMouseMove;
  1305.     property OnMouseUp;
  1306.   end;
  1307.  
  1308. { THotKey }
  1309.  
  1310.   THKModifier = (hkShift, hkCtrl, hkAlt, hkExt);
  1311.   THKModifiers = set of THKModifier;
  1312.   THKInvalidKey = (hcNone, hcShift, hcCtrl, hcAlt, hcShiftCtrl,
  1313.     hcShiftAlt, hcCtrlAlt, hcShiftCtrlAlt);
  1314.   THKInvalidKeys = set of THKInvalidKey;
  1315.  
  1316.   TCustomHotKey = class(TWinControl)
  1317.   private
  1318.     FAutoSize: Boolean;
  1319.     FModifiers: THKModifiers;
  1320.     FInvalidKeys: THKInvalidKeys;
  1321.     FHotKey: Word;
  1322.     procedure AdjustHeight;
  1323.     procedure SetAutoSize(Value: Boolean);
  1324.     procedure SetInvalidKeys(Value: THKInvalidKeys);
  1325.     procedure SetModifiers(Value: THKModifiers);
  1326.     procedure UpdateHeight;
  1327.     function GetHotKey: TShortCut;
  1328.     procedure SetHotKey(Value: TShortCut);
  1329.     procedure ShortCutToHotKey(Value: TShortCut);
  1330.     function HotKeyToShortCut(Value: Longint): TShortCut;
  1331.   protected
  1332.     procedure CreateParams(var Params: TCreateParams); override;
  1333.     procedure CreateWnd; override;
  1334.     property AutoSize: Boolean read FAutoSize write SetAutoSize default True;
  1335.     property InvalidKeys: THKInvalidKeys read FInvalidKeys write SetInvalidKeys;
  1336.     property Modifiers: THKModifiers read FModifiers write SetModifiers;
  1337.     property HotKey: TShortCut read GetHotKey write SetHotKey;
  1338.     property TabStop default True;
  1339.   public
  1340.     constructor Create(AOwner: TComponent); override;
  1341.   end;
  1342.  
  1343.   THotKey = class(TCustomHotKey)
  1344.   published
  1345.     property AutoSize;
  1346.     property Enabled;
  1347.     property Hint;
  1348.     property HotKey;
  1349.     property InvalidKeys;
  1350.     property Modifiers;
  1351.     property ParentShowHint;
  1352.     property PopupMenu;
  1353.     property ShowHint;
  1354.     property TabOrder;
  1355.     property TabStop;
  1356.     property Visible;
  1357.     property OnEnter;
  1358.     property OnExit;
  1359.     property OnMouseDown;
  1360.     property OnMouseMove;
  1361.     property OnMouseUp;
  1362.   end;
  1363.  
  1364. const
  1365.   ColumnHeaderWidth = LVSCW_AUTOSIZE_USEHEADER;
  1366.   ColumnTextWidth = LVSCW_AUTOSIZE;
  1367.  
  1368. type
  1369.   TListColumns = class;
  1370.   TListItems = class;
  1371.   TCustomListView = class;
  1372.   TWidth = ColumnHeaderWidth..MaxInt;
  1373.  
  1374.   TListColumn = class(TCollectionItem)
  1375.   private
  1376.     FCaption: string;
  1377.     FAlignment: TAlignment;
  1378.     FWidth: TWidth;
  1379.     FPrivateWidth: TWidth;
  1380.     procedure DoChange;
  1381.     function GetWidth: TWidth;
  1382.     procedure ReadData(Reader: TReader);
  1383.     procedure SetAlignment(Value: TAlignment);
  1384.     procedure SetCaption(const Value: string);
  1385.     procedure SetWidth(Value: TWidth);
  1386.     procedure WriteData(Writer: TWriter);
  1387.   protected
  1388.     procedure DefineProperties(Filer: TFiler); override;
  1389.     function GetDisplayName: string; override;
  1390.   public
  1391.     constructor Create(Collection: TCollection); override;
  1392.     destructor Destroy; override;
  1393.     procedure Assign(Source: TPersistent); override;
  1394.     property WidthType: TWidth read FWidth;
  1395.   published
  1396.     property Alignment: TAlignment read FAlignment write SetAlignment default taLeftJustify;
  1397.     property Caption: string read FCaption write SetCaption;
  1398.     property Width: TWidth read GetWidth write SetWidth default 50;
  1399.   end;
  1400.  
  1401.   TListColumns = class(TCollection)
  1402.   private
  1403.     FOwner: TCustomListView;
  1404.     function GetItem(Index: Integer): TListColumn;
  1405.     procedure SetItem(Index: Integer; Value: TListColumn);
  1406.   protected
  1407.     function GetOwner: TPersistent; override;
  1408.     procedure Update(Item: TCollectionItem); override;
  1409.   public
  1410.     constructor Create(AOwner: TCustomListView);
  1411.     function Add: TListColumn;
  1412.     property Owner: TCustomListView read FOwner;
  1413.     property Items[Index: Integer]: TListColumn read GetItem write SetItem; default;
  1414.   end;
  1415.  
  1416.   TDisplayCode = (drBounds, drIcon, drLabel, drSelectBounds);
  1417.  
  1418.   { TListItem }
  1419.  
  1420.   TListItem = class(TPersistent)
  1421.   private
  1422.     FOwner: TListItems;
  1423.     FSubItems: TStrings;
  1424.     FData: Pointer;
  1425.     FImageIndex: Integer;
  1426.     FOverlayIndex: Integer;
  1427.     FStateIndex: Integer;
  1428.     FCaption: string;
  1429.     FDeleting: Boolean;
  1430.     FProcessedDeleting: Boolean;
  1431.     function GetChecked: Boolean;
  1432.     function GetHandle: HWND;
  1433.     function GetIndex: Integer;
  1434.     function GetListView: TCustomListView;
  1435.     function GetLeft: Integer;
  1436.     function GetState(Index: Integer): Boolean;
  1437.     function GetTop: Integer;
  1438.     function IsEqual(Item: TListItem): Boolean;
  1439.     procedure SetChecked(Value: Boolean);
  1440.     procedure SetCaption(const Value: string);
  1441.     procedure SetData(Value: Pointer);
  1442.     procedure SetImage(Index: Integer; Value: Integer);
  1443.     procedure SetLeft(Value: Integer);
  1444.     procedure SetState(Index: Integer; State: Boolean);
  1445.     procedure SetSubItems(Value: TStrings);
  1446.     procedure SetTop(Value: Integer);
  1447.   protected
  1448.     procedure Assign(Source: TPersistent); override;
  1449.   public
  1450.     constructor Create(AOwner: TListItems);
  1451.     destructor Destroy; override;
  1452.     procedure CancelEdit;
  1453.     procedure Delete;
  1454.     function DisplayRect(Code: TDisplayCode): TRect;
  1455.     function EditCaption: Boolean;
  1456.     function GetPosition: TPoint;
  1457.     procedure MakeVisible(PartialOK: Boolean);
  1458.     procedure Update;
  1459.     procedure SetPosition(const Value: TPoint);
  1460.     property Caption: string read FCaption write SetCaption;
  1461.     property Checked: Boolean read GetChecked write SetChecked;
  1462.     property Cut: Boolean index 0 read GetState write SetState;
  1463.     property Data: Pointer read FData write SetData;
  1464.     property DropTarget: Boolean index 1 read GetState write SetState;
  1465.     property Focused: Boolean index 2 read GetState write SetState;
  1466.     property Handle: HWND read GetHandle;
  1467.     property ImageIndex: Integer index 0 read FImageIndex write SetImage;
  1468.     property Index: Integer read GetIndex;
  1469.     property Left: Integer read GetLeft write SetLeft;
  1470.     property ListView: TCustomListView read GetListView;
  1471.     property Owner: TListItems read FOwner;
  1472.     property OverlayIndex: Integer index 1 read FOverlayIndex write SetImage;
  1473.     property Selected: Boolean index 3 read GetState write SetState;
  1474.     property StateIndex: Integer index 2 read FStateIndex write SetImage;
  1475.     property SubItems: TStrings read FSubItems write SetSubItems;
  1476.     property Top: Integer read GetTop write SetTop;
  1477.   end;
  1478.  
  1479. { TListItems }
  1480.  
  1481.   TListItems = class(TPersistent)
  1482.   private
  1483.     FOwner: TCustomListView;
  1484.     FUpdateCount: Integer;
  1485.     FNoRedraw: Boolean;
  1486.     procedure ReadData(Stream: TStream);
  1487.     procedure WriteData(Stream: TStream);
  1488.   protected
  1489.     procedure DefineProperties(Filer: TFiler); override;
  1490.     function CreateItem(Index: Integer; ListItem: TListItem): TLVItem;
  1491.     function GetCount: Integer;
  1492.     function GetHandle: HWND;
  1493.     function GetItem(Index: Integer): TListItem;
  1494.     procedure SetItem(Index: Integer; Value: TListItem);
  1495.     procedure SetUpdateState(Updating: Boolean);
  1496.   public
  1497.     constructor Create(AOwner: TCustomListView);
  1498.     destructor Destroy; override;
  1499.     function Add: TListItem;
  1500.     procedure Assign(Source: TPersistent); override;
  1501.     procedure BeginUpdate;
  1502.     procedure Clear;
  1503.     procedure Delete(Index: Integer);
  1504.     procedure EndUpdate;
  1505.     function IndexOf(Value: TListItem): Integer;
  1506.     function Insert(Index: Integer): TListItem;
  1507.     property Count: Integer read GetCount;
  1508.     property Handle: HWND read GetHandle;
  1509.     property Item[Index: Integer]: TListItem read GetItem write SetItem; default;
  1510.     property Owner: TCustomListView read FOwner;
  1511.   end;
  1512.  
  1513.   { TIconOptions }
  1514.   TIconArrangement = (iaTop, iaLeft);
  1515.  
  1516.   TIconOptions = class(TPersistent)
  1517.   private
  1518.     FListView: TCustomListView;
  1519.     FArrangement: TIconArrangement;
  1520.     FAutoArrange: Boolean;
  1521.     FWrapText: Boolean;
  1522.     procedure SetArrangement(Value: TIconArrangement);
  1523.     procedure SetAutoArrange(Value: Boolean);
  1524.     procedure SetWrapText(Value: Boolean);
  1525.   public
  1526.     constructor Create(AOwner: TCustomListView);
  1527.   published
  1528.     property Arrangement: TIconArrangement read FArrangement write SetArrangement default iaTop;
  1529.     property AutoArrange: Boolean read FAutoArrange write SetAutoArrange default False;
  1530.     property WrapText: Boolean read FWrapText write SetWrapText default True;
  1531.   end;
  1532.  
  1533.   TListArrangement = (arAlignBottom, arAlignLeft, arAlignRight,
  1534.     arAlignTop, arDefault, arSnapToGrid);
  1535.   TViewStyle = (vsIcon, vsSmallIcon, vsList, vsReport);
  1536.   TItemState = (isNone, isCut, isDropHilited, isFocused, isSelected);
  1537.   TItemStates = set of TItemState;
  1538.   TItemChange = (ctText, ctImage, ctState);
  1539.   TLVDeletedEvent = procedure(Sender: TObject; Item: TListItem) of object;
  1540.   TLVEditingEvent = procedure(Sender: TObject; Item: TListItem;
  1541.     var AllowEdit: Boolean) of object;
  1542.   TLVEditedEvent = procedure(Sender: TObject; Item: TListItem; var S: string) of object;
  1543.   TLVChangeEvent = procedure(Sender: TObject; Item: TListItem;
  1544.     Change: TItemChange) of object;
  1545.   TLVChangingEvent = procedure(Sender: TObject; Item: TListItem;
  1546.     Change: TItemChange; var AllowChange: Boolean) of object;
  1547.   TLVColumnClickEvent = procedure(Sender: TObject; Column: TListColumn) of object;
  1548.   TLVCompareEvent = procedure(Sender: TObject; Item1, Item2: TListItem;
  1549.     Data: Integer; var Compare: Integer) of object;
  1550.   TSearchDirection = (sdLeft, sdRight, sdAbove, sdBelow, sdAll);
  1551.  
  1552.   { TCustomListView }
  1553.   TCustomListView = class(TWinControl)
  1554.   private
  1555.     FBorderStyle: TBorderStyle;
  1556.     FViewStyle: TViewStyle;
  1557.     FReadOnly: Boolean;
  1558.     FLargeImages: TImageList;
  1559.     FSmallImages: TImageList;
  1560.     FStateImages: TImageList;
  1561.     FDragImage: TImageList;
  1562.     FMultiSelect: Boolean;
  1563.     FSortType: TSortType;
  1564.     FColumnClick: Boolean;
  1565.     FShowColumnHeaders: Boolean;
  1566.     FListItems: TListItems;
  1567.     FClicked: Boolean;
  1568.     FRClicked: Boolean;
  1569.     FIconOptions: TIconOptions;
  1570.     FHideSelection: Boolean;
  1571.     FListColumns: TListColumns;
  1572.     FMemStream: TMemoryStream;
  1573.     FEditInstance: Pointer;
  1574.     FDefEditProc: Pointer;
  1575.     FEditHandle: HWND;
  1576.     FHeaderInstance: Pointer;
  1577.     FDefHeaderProc: Pointer;
  1578.     FHeaderHandle: HWND;
  1579.     FAllocBy: Integer;
  1580.     FDragIndex: Integer;
  1581.     FLastDropTarget: TListItem;
  1582.     FCheckboxes: Boolean;
  1583.     FGridLines: Boolean;
  1584.     FHotTrack: Boolean;
  1585.     FRowSelect: Boolean;
  1586.     FLargeChangeLink: TChangeLink;
  1587.     FSmallChangeLink: TChangeLink;
  1588.     FStateChangeLink: TChangeLink;
  1589.     FOnChange: TLVChangeEvent;
  1590.     FOnChanging: TLVChangingEvent;
  1591.     FOnColumnClick: TLVColumnClickEvent;
  1592.     FOnDeletion: TLVDeletedEvent;
  1593.     FOnEditing: TLVEditingEvent;
  1594.     FOnEdited: TLVEditedEvent;
  1595.     FOnInsert: TLVDeletedEvent;
  1596.     FOnCompare: TLVCompareEvent;
  1597.     procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED;
  1598.     procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
  1599.     procedure CMDrag(var Message: TCMDrag); message CM_DRAG;
  1600.     procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
  1601.     procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY;
  1602.     procedure DoDragOver(Source: TDragObject; X, Y: Integer);
  1603.     procedure EditWndProc(var Message: TMessage);
  1604.     function GetBoundingRect: TRect;
  1605.     function GetColumnFromIndex(Index: Integer): TListColumn;
  1606.     function GetDropTarget: TListItem;
  1607.     function GetFocused: TListItem;
  1608.     function GetItem(Value: TLVItem): TListItem;
  1609.     function GetSelCount: Integer;
  1610.     function GetSelection: TListItem;
  1611.     function GetTopItem: TListItem;
  1612.     function GetViewOrigin: TPoint;
  1613.     function GetVisibleRowCount: Integer;
  1614.     procedure HeaderWndProc(var Message: TMessage);
  1615.     procedure ImageListChange(Sender: TObject);
  1616.     procedure InsertItem(Item: TListItem); dynamic;
  1617.     procedure SetBorderStyle(Value: TBorderStyle);
  1618.     procedure SetColumnClick(Value: Boolean);
  1619.     procedure SetColumnHeaders(Value: Boolean);
  1620.     procedure SetDropTarget(Value: TListItem);
  1621.     procedure SetFocused(Value: TListItem);
  1622.     procedure SetHideSelection(Value: Boolean);
  1623. //    procedure SetIconArrangement(Value: TIconArrangement);
  1624.     procedure SetIconOptions(Value: TIconOptions);
  1625.     procedure SetImageList(Value: HImageList; Flags: Integer);
  1626.     procedure SetLargeImages(Value: TImageList);
  1627.     procedure SetAllocBy(Value: Integer);
  1628.     procedure SetItems(Value: TListItems);
  1629.     procedure SetListColumns(Value: TListColumns);
  1630.     procedure SetMultiSelect(Value: Boolean);
  1631.     procedure SetReadOnly(Value: Boolean);
  1632.     procedure SetSmallImages(Value: TImageList);
  1633.     procedure SetSortType(Value: TSortType);
  1634.     procedure SetSelection(Value: TListItem);
  1635.     procedure SetStateImages(Value: TImageList);
  1636.     procedure SetTextBkColor(Value: TColor);
  1637.     procedure SetTextColor(Value: TColor);
  1638.     procedure SetViewStyle(Value: TViewStyle);
  1639.     procedure SetCheckboxes(Value: Boolean);
  1640.     procedure SetGridLines(Value: Boolean);
  1641.     procedure SetHotTrack(Value: Boolean);
  1642.     procedure SetRowSelect(Value: Boolean);
  1643.     procedure ResetExStyles;
  1644.     function ValidHeaderHandle: Boolean;
  1645.     procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
  1646.     procedure WMNotify(var Message: TWMNotify); message WM_NOTIFY;
  1647.     procedure WMParentNotify(var Message: TWMParentNotify); message WM_PARENTNOTIFY;
  1648.     procedure WMRButtonDown(var Message: TWMRButtonDown); message WM_RBUTTONDOWN;
  1649.   protected
  1650.     function CanChange(Item: TListItem; Change: Integer): Boolean; dynamic;
  1651.     function CanEdit(Item: TListItem): Boolean; dynamic;
  1652.     procedure Change(Item: TListItem; Change: Integer); dynamic;
  1653.     procedure ColClick(Column: TListColumn); dynamic;
  1654.     function ColumnsShowing: Boolean;
  1655.     function CreateListItem: TListItem; virtual;
  1656.     procedure CreateParams(var Params: TCreateParams); override;
  1657.     procedure CreateWnd; override;
  1658.     procedure Delete(Item: TListItem); dynamic;
  1659.     procedure DestroyWnd; override;
  1660.     procedure DoEndDrag(Target: TObject; X, Y: Integer); override;
  1661.     procedure DoStartDrag(var DragObject: TDragObject); override;
  1662.     procedure Edit(const Item: TLVItem); dynamic;
  1663.     function GetDragImages: TCustomImageList; override;
  1664.     function GetItemIndex(Value: TListItem): Integer;
  1665.     procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  1666.     procedure UpdateColumn(Index: Integer);
  1667.     procedure UpdateColumns;
  1668.     procedure WndProc(var Message: TMessage); override;
  1669.     property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;
  1670.     property Columns: TListColumns read FListColumns write SetListColumns;
  1671.     property ColumnClick: Boolean read FColumnClick write SetColumnClick default True;
  1672.     property ReadOnly: Boolean read FReadOnly write SetReadOnly;
  1673.     property HideSelection: Boolean read FHideSelection write SetHideSelection default True;
  1674.     property IconOptions: TIconOptions read FIconOptions write SetIconOptions;
  1675.     property Items: TListItems read FListItems write SetItems;
  1676.     property AllocBy: Integer read FAllocBy write SetAllocBy default 0;
  1677.     property LargeImages: TImageList read FLargeImages write SetLargeImages;
  1678.     property MultiSelect: Boolean read FMultiSelect write SetMultiSelect default False;
  1679.     property OnChange: TLVChangeEvent read FOnChange write FOnChange;
  1680.     property OnChanging: TLVChangingEvent read FOnChanging write FOnChanging;
  1681.     property OnColumnClick: TLVColumnClickEvent read FOnColumnClick
  1682.       write FOnColumnClick;
  1683.     property OnCompare: TLVCompareEvent read FOnCompare write FOnCompare;
  1684.     property OnDeletion: TLVDeletedEvent read FOnDeletion write FOnDeletion;
  1685.     property OnEdited: TLVEditedEvent read FOnEdited write FOnEdited;
  1686.     property OnEditing: TLVEditingEvent read FOnEditing write FOnEditing;
  1687.     property OnInsert: TLVDeletedEvent read FOnInsert write FOnInsert;
  1688.     property ShowColumnHeaders: Boolean read FShowColumnHeaders write
  1689.       SetColumnHeaders default True;
  1690.     property SmallImages: TImageList read FSmallImages write SetSmallImages;
  1691.     property SortType: TSortType read FSortType write SetSortType default stNone;
  1692.     property StateImages: TImageList read FStateImages write SetStateImages;
  1693.     property ViewStyle: TViewStyle read FViewStyle write SetViewStyle default vsIcon;
  1694.   public
  1695.     constructor Create(AOwner: TComponent); override;
  1696.     destructor Destroy; override;
  1697.     function AlphaSort: Boolean;
  1698.     procedure Arrange(Code: TListArrangement);
  1699.     function FindCaption(StartIndex: Integer; Value: string;
  1700.       Partial, Inclusive, Wrap: Boolean): TListItem;
  1701.     function FindData(StartIndex: Integer; Value: Pointer;
  1702.       Inclusive, Wrap: Boolean): TListItem;
  1703.     function GetItemAt(X, Y: Integer): TListItem;
  1704.     function GetNearestItem(Point: TPoint;
  1705.       Direction: TSearchDirection): TListItem;
  1706.     function GetNextItem(StartItem: TListItem;
  1707.       Direction: TSearchDirection; States: TItemStates): TListItem;
  1708.     function GetSearchString: string;
  1709.     function IsEditing: Boolean;
  1710.     procedure Scroll(DX, DY: Integer);
  1711.     property Checkboxes: Boolean read FCheckboxes write SetCheckboxes default False;
  1712.     property Column[Index: Integer]: TListColumn read GetColumnFromIndex;
  1713.     property DropTarget: TListItem read GetDropTarget write SetDropTarget;
  1714.     property GridLines: Boolean read FGridLines write SetGridLines default False;
  1715.     property HotTrack: Boolean read FHotTrack write SetHotTrack default False;
  1716.     property ItemFocused: TListItem read GetFocused write SetFocused;
  1717.     property RowSelect: Boolean read FRowSelect write SetRowSelect default False;
  1718.     property SelCount: Integer read GetSelCount;
  1719.     property Selected: TListItem read GetSelection write SetSelection;
  1720.     function CustomSort(SortProc: TLVCompare; lParam: Longint): Boolean;
  1721.     function StringWidth(S: string): Integer;
  1722.     procedure UpdateItems(FirstIndex, LastIndex: Integer);
  1723.     property TopItem: TListItem read GetTopItem;
  1724.     property ViewOrigin: TPoint read GetViewOrigin;
  1725.     property VisibleRowCount: Integer read GetVisibleRowCount;
  1726.     property BoundingRect: TRect read GetBoundingRect;
  1727.   end;
  1728.  
  1729.   { TListView }
  1730.   TListView = class(TCustomListView)
  1731.   published
  1732.     property Align;
  1733.     property BorderStyle;
  1734.     property Checkboxes;
  1735.     property Color;
  1736.     property ColumnClick;
  1737.     property OnClick;
  1738.     property OnDblClick;
  1739.     property Columns;
  1740.     property Ctl3D;
  1741.     property DragMode;
  1742.     property ReadOnly default False;
  1743.     property Font;
  1744.     property GridLines;
  1745.     property HideSelection;
  1746.     property HotTrack;
  1747.     property IconOptions;
  1748.     property Items;
  1749.     property AllocBy;
  1750.     property MultiSelect;
  1751.     property RowSelect;
  1752.     property OnChange;
  1753.     property OnChanging;
  1754.     property OnColumnClick;
  1755.     property OnCompare;
  1756.     property OnDeletion;
  1757.     property OnEdited;
  1758.     property OnEditing;
  1759.     property OnEnter;
  1760.     property OnExit;
  1761.     property OnInsert;
  1762.     property OnDragDrop;
  1763.     property OnDragOver;
  1764.     property DragCursor;
  1765.     property OnStartDrag;
  1766.     property OnEndDrag;
  1767.     property OnMouseDown;
  1768.     property OnMouseMove;
  1769.     property OnMouseUp;
  1770.     property ParentColor default False;
  1771.     property ParentFont;
  1772.     property ParentShowHint;
  1773.     property ShowHint;
  1774.     property PopupMenu;
  1775.     property ShowColumnHeaders;
  1776.     property SortType;
  1777.     property TabOrder;
  1778.     property TabStop default True;
  1779.     property ViewStyle;
  1780.     property Visible;
  1781.     property OnKeyDown;
  1782.     property OnKeyPress;
  1783.     property OnKeyUp;
  1784.     property LargeImages;
  1785.     property SmallImages;
  1786.     property StateImages;
  1787.   end;
  1788.  
  1789. { TAnimate }
  1790.  
  1791.   TCommonAVI = (caNone, caFindFolder, caFindFile, caFindComputer, caCopyFiles,
  1792.     caCopyFile, caRecycleFile, caEmptyRecycle, caDeleteFile);   
  1793.  
  1794.   TAnimate = class(TWinControl)
  1795.   private
  1796.     FActive: Boolean;
  1797.     FAutoSize: Boolean;
  1798.     FFileName: string;
  1799.     FCenter: Boolean;
  1800.     FCommonAVI: TCommonAVI;
  1801.     FFrameCount: Integer;
  1802.     FFrameHeight: Integer;
  1803.     FFrameWidth: Integer;
  1804.     FOpen: Boolean;
  1805.     FRecreateNeeded: Boolean;
  1806.     FRepetitions: Integer;
  1807.     FResHandle: THandle;
  1808.     FResId: Integer;
  1809.     FResName: string;
  1810.     FStreamedActive: Boolean;
  1811.     FTimers: Boolean;
  1812.     FTransparent: Boolean;
  1813.     FStartFrame: Word;
  1814.     FStopFrame: Word;
  1815.     FOnOpen: TNotifyEvent;
  1816.     FOnClose: TNotifyEvent;
  1817.     FOnStart: TNotifyEvent;
  1818.     FOnStop: TNotifyEvent;
  1819.     procedure CheckOpen;
  1820.     function InternalClose: Boolean;
  1821.     function InternalOpen: Boolean;
  1822.     procedure Resize;
  1823.     function GetActualResHandle: THandle;
  1824.     function GetActualResId: Integer;
  1825.     procedure GetFrameInfo;
  1826.     procedure SetActive(Value: Boolean);
  1827.     procedure SetAutoSize(Value: Boolean);
  1828.     procedure SetFileName(Value: string);
  1829.     procedure SetCenter(Value: Boolean);
  1830.     procedure SetCommonAVI(Value: TCommonAVI);
  1831.     procedure SetOpen(Value: Boolean);
  1832.     procedure SetRepetitions(Value: Integer);
  1833.     procedure SetResHandle(Value: THandle);
  1834.     procedure SetResId(Value: Integer);
  1835.     procedure SetResName(Value: string);
  1836.     procedure SetTimers(Value: Boolean);
  1837.     procedure SetTransparent(Value: Boolean);
  1838.     procedure SetStartFrame(Value: Word);
  1839.     procedure SetStopFrame(Value: Word);
  1840.     procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
  1841.     procedure WMSize(var Message: TMessage); message WM_SIZE;
  1842.     procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED;
  1843.     procedure CMRecreateWnd(var Message: TMessage); message CM_RECREATEWND;
  1844.     procedure CNCommand(var Message: TWMCommand); message CN_COMMAND;
  1845.   protected
  1846.     procedure AlignControls(AControl: TControl; var Rect: TRect); override;
  1847.     procedure CreateParams(var Params: TCreateParams); override;
  1848.     procedure CreateHandle; override;
  1849.     procedure DoOpen; virtual;
  1850.     procedure DoClose; virtual;
  1851.     procedure DoStart; virtual;
  1852.     procedure DoStop; virtual;
  1853.     procedure Loaded; override;
  1854.   public
  1855.     constructor Create(AOwner: TComponent); override;
  1856.     property FrameCount: Integer read FFrameCount;
  1857.     property FrameHeight: Integer read FFrameHeight;
  1858.     property FrameWidth: Integer read FFrameWidth;
  1859.     property Open: Boolean read FOpen write SetOpen;
  1860.     procedure Play(FromFrame, ToFrame: Word; Count: Integer);
  1861.     procedure Reset;
  1862.     procedure Seek(Frame: Integer);
  1863.     procedure Stop;
  1864.     property ResHandle: THandle read FResHandle write SetResHandle;
  1865.     property ResId: Integer read FResId write SetResId;
  1866.     property ResName: string read FResName write SetResName;
  1867.   published
  1868.     property Active: Boolean read FActive write SetActive;
  1869.     property AutoSize: Boolean read FAutoSize write SetAutoSize default True;
  1870.     property Align;
  1871.     property Center: Boolean read FCenter write SetCenter default True;
  1872.     property Color;
  1873.     property CommonAVI: TCommonAVI read FCommonAVI write SetCommonAVI;
  1874.     property FileName: string read FFileName write SetFileName;
  1875.     property ParentColor;
  1876.     property Repetitions: Integer read FRepetitions write SetRepetitions default -1;
  1877.     property StartFrame: Word read FStartFrame write SetStartFrame default 0;
  1878.     property StopFrame: Word read FStopFrame write SetStopFrame default Word(-1);
  1879.     property Timers: Boolean read FTimers write SetTimers default False;
  1880.     property Transparent: Boolean read FTransparent write SetTransparent default True;
  1881.     property Visible;
  1882.     property OnOpen: TNotifyEvent read FOnOpen write FOnOpen;
  1883.     property OnClose: TNotifyEvent read FOnClose write FOnClose;
  1884.     property OnStart: TNotifyEvent read FOnStart write FOnStart;
  1885.     property OnStop: TNotifyEvent read FOnStop write FOnStop;
  1886.   end;
  1887.  
  1888. { TToolButton }
  1889.  
  1890.   TToolButtonStyle = (tbsButton, tbsCheck, tbsDropDown, tbsSeparator, tbsDivider);
  1891.  
  1892.   TToolButtonState = (tbsChecked, tbsPressed, tbsEnabled, tbsHidden,
  1893.     tbsIndeterminate, tbsWrap, tbsEllipses);
  1894.  
  1895.   TToolBar = class;
  1896.  
  1897.   TToolButton = class(TGraphicControl)
  1898.   private
  1899.     FDown: Boolean;
  1900. //    FEllipses: Boolean;
  1901.     FGrouped: Boolean;
  1902.     FImageIndex: Integer;
  1903.     FIndeterminate: Boolean;
  1904.     FWrap: Boolean;
  1905.     FInMouseMove: Boolean;
  1906.     FStreamedDown: Boolean;
  1907.     FStyle: TToolButtonStyle;
  1908.     FUpdateCount: Integer;
  1909.     FDoHitTest: Boolean;
  1910.     procedure DoDropDown;
  1911.     function GetButtonState: Word;
  1912.     function GetIndex: Integer;
  1913.     function IsDown: Boolean;
  1914.     procedure SetDown(Value: Boolean);
  1915. //    procedure SetEllipses(Value: Boolean);
  1916.     procedure SetGrouped(Value: Boolean);
  1917.     procedure SetImageIndex(Value: Integer);
  1918.     procedure SetIndeterminate(Value: Boolean);
  1919.     procedure SetStyle(Value: TToolButtonStyle);
  1920.     procedure SetWrap(Value: Boolean);
  1921.     procedure WMWindowPosChanged(var Message: TWMWindowPosChanged); message WM_WINDOWPOSCHANGED;
  1922.     procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
  1923.     procedure CMHitTest(var Message: TCMHitTest); message CM_HITTEST;
  1924.     procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
  1925.     procedure CMVisibleChanged(var Message: TMessage); message CM_VISIBLECHANGED;
  1926.   protected
  1927.     FToolBar: TToolBar;
  1928.     procedure BeginUpdate; virtual;
  1929.     procedure EndUpdate; virtual;
  1930.     procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
  1931.       X, Y: Integer); override;
  1932.     procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
  1933.     procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
  1934.       X, Y: Integer); override;
  1935.     procedure Paint; override;
  1936.     procedure UpdateControl; virtual;
  1937.     procedure SetToolBar(AToolBar: TToolBar);
  1938.     property Index: Integer read GetIndex;
  1939.   public
  1940.     constructor Create(AOwner: TComponent); override;
  1941.     destructor Destroy; override;
  1942.   published
  1943.     property Caption;
  1944.     property Down: Boolean read FDown write SetDown default False;
  1945.     property DragCursor;
  1946.     property DragMode;
  1947. //    property Ellipses: Boolean read FEllipses write SetEllipses default False;
  1948.     property Enabled;
  1949.     property Grouped: Boolean read FGrouped write SetGrouped default False;
  1950.     property ImageIndex: Integer read FImageIndex write SetImageIndex;
  1951.     property Indeterminate: Boolean read FIndeterminate write SetIndeterminate default False;
  1952.     property ParentShowHint;
  1953.     property PopupMenu;
  1954.     property Wrap: Boolean read FWrap write SetWrap default False;
  1955.     property ShowHint;
  1956.     property Style: TToolButtonStyle read FStyle write SetStyle default tbsButton;
  1957.     property Visible;
  1958.     property OnClick;
  1959.     property OnDragDrop;
  1960.     property OnDragOver;
  1961.     property OnEndDrag;
  1962.     property OnMouseDown;
  1963.     property OnMouseMove;
  1964.     property OnMouseUp;
  1965.     property OnStartDrag;
  1966.   end;
  1967.  
  1968. { TToolBar }
  1969.  
  1970.   TToolBar = class(TToolWindow)
  1971.   private
  1972.     FAllowAllUp: Boolean;
  1973.     FAutoSize: Boolean;
  1974.     FBitmapWidth: Integer;
  1975.     FBitmapHeight: Integer;
  1976.     FButtonWidth: Integer;
  1977.     FButtonHeight: Integer;
  1978.     FDivider: Boolean;
  1979.     FShowCaptions: Boolean;
  1980.     FList: Boolean;
  1981.     FFlat: Boolean;
  1982.     FWrapable: Boolean;
  1983.     FButtons: TList;
  1984.     FImages: TImageList;
  1985.     FImageChangeLink: TChangeLink;
  1986.     FDisabledImages: TImageList;
  1987.     FDisabledImageChangeLink: TChangeLink;
  1988.     FHotImages: TImageList;
  1989.     FHotImageChangeLink: TChangeLink;
  1990.     FIndent: Integer;
  1991.     FUpdateCount: Integer;
  1992.     FHeightMargin: Integer;
  1993.     FNewStyle: Boolean;
  1994.     FOldHandle: HBitmap;
  1995.     FBitmap: TBitmap;
  1996.     FNullBitmap: TBitmap;
  1997.     FOnResize: TNotifyEvent;
  1998.     procedure SetAutoSize(Value: Boolean);
  1999.     procedure LoadImage(AImages: TImageList);
  2000.     function GetRowCount: Integer;
  2001.     procedure SetDivider(Value: Boolean);
  2002.     procedure SetList(Value: Boolean);
  2003.     procedure SetShowCaptions(Value: Boolean);
  2004.     procedure SetFlat(Value: Boolean);
  2005.     procedure SetWrapable(Value: Boolean);
  2006.     procedure InsertButton(Control: TControl);
  2007.     procedure RemoveButton(Control: TControl);
  2008.     procedure UpdateButton(const Index: Integer);
  2009.     procedure UpdateButtons;
  2010.     procedure UpdateItem(const Message, FromIndex, ToIndex: Integer);
  2011.     procedure CreateButtons;
  2012.     procedure SetButtonWidth(Value: Integer);
  2013.     procedure SetButtonHeight(Value: Integer);
  2014.     procedure UpdateImages;
  2015.     procedure ImageListChange(Sender: TObject);
  2016.     procedure SetImageList(Value: HImageList);
  2017.     procedure SetImages(Value: TImageList);
  2018.     procedure DisabledImageListChange(Sender: TObject);
  2019.     procedure SetDisabledImageList(Value: HImageList);
  2020.     procedure SetDisabledImages(Value: TImageList);
  2021.     procedure HotImageListChange(Sender: TObject);
  2022.     procedure SetHotImageList(Value: HImageList);
  2023.     procedure SetHotImages(Value: TImageList);
  2024.     procedure SetIndent(Value: Integer);
  2025.     procedure Reposition;
  2026.     procedure Recreate;
  2027.     procedure BeginUpdate;
  2028.     procedure EndUpdate;
  2029.     procedure ResizeButtons;
  2030.     function ButtonCount: Integer;
  2031.     procedure OrderButton(const Index: Integer);
  2032.     procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
  2033.     procedure WMSize(var Message: TWMSize); message WM_SIZE;
  2034.     procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED;
  2035.     procedure CMControlChange(var Message: TCMControlChange); message CM_CONTROLCHANGE;
  2036.     procedure CMRecreateWnd(var Message: TMessage); message CM_RECREATEWND;
  2037.     procedure TBAutoSize(var Message: TMessage); message TB_AUTOSIZE;
  2038.   protected
  2039.     procedure AlignControls(AControl: TControl; var Rect: TRect); override;
  2040.     procedure CreateParams(var Params: TCreateParams); override;
  2041.     procedure CreateWnd; override;
  2042.     procedure Resize; dynamic;
  2043.     procedure Notification(AComponent: TComponent;
  2044.       Operation: TOperation); override;
  2045.     procedure RepositionButton(const Index: Integer);
  2046.     procedure RepositionButtons;
  2047.     procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
  2048.     procedure Loaded; override;
  2049.   public
  2050.     constructor Create(AOwner: TComponent); override;
  2051.     destructor Destroy; override;
  2052.     property Buttons: TList read FButtons;
  2053. //    property ButtonCount: Integer read GetButtonCount;
  2054. //    property Buttons[Index: Integer]: TToolButton read GetButton;
  2055.     procedure ClearButtons;
  2056.     property RowCount: Integer read GetRowCount;
  2057.   published
  2058.     property Align default alTop;
  2059.     property AllowAllUp: Boolean read FAllowAllUp write FAllowAllUp;
  2060.     property AutoSize: Boolean read FAutoSize write SetAutoSize;
  2061.     property BorderStyle default bsNone;
  2062.     property BorderWidth;
  2063.     property ButtonHeight: Integer read FButtonHeight write SetButtonHeight default 22;
  2064.     property ButtonWidth: Integer read FButtonWidth write SetButtonWidth default 23;
  2065.     property Color;
  2066.     property Ctl3D;
  2067.     property DisabledImages: TImageList read FDisabledImages write SetDisabledImages;
  2068.     property Divider: Boolean read FDivider write SetDivider default True;
  2069.     property DragCursor;
  2070.     property DragMode;
  2071.     property Enabled;
  2072.     property Flat: Boolean read FFlat write SetFlat default False;
  2073.     property Font;
  2074.     property Height default 32;
  2075.     property HotImages: TImageList read FHotImages write SetHotImages;
  2076.     property Images: TImageList read FImages write SetImages;
  2077.     property Indent: Integer read FIndent write SetIndent default 0;
  2078.     property List: Boolean read FList write SetList default False;
  2079.     property ParentColor;
  2080.     property ParentFont;
  2081.     property ParentShowHint;
  2082.     property PopupMenu;
  2083.     property ShowCaptions: Boolean read FShowCaptions write SetShowCaptions default False;
  2084.     property ShowHint;
  2085.     property TabOrder;
  2086.     property TabStop;
  2087.     property Visible;
  2088.     property Wrapable: Boolean read FWrapable write SetWrapable default True;
  2089.     property OnClick;
  2090.     property OnDblClick;
  2091.     property OnDragDrop;
  2092.     property OnDragOver;
  2093.     property OnEndDrag;
  2094.     property OnMouseDown;
  2095.     property OnMouseMove;
  2096.     property OnMouseUp;
  2097.     property OnResize: TNotifyEvent read FOnResize write FOnResize;
  2098.     property OnStartDrag;
  2099.   end;
  2100.  
  2101. { TCoolBar }
  2102.  
  2103. const
  2104.   CM_BANDCHANGE = WM_USER + 15;
  2105.  
  2106. type
  2107.  
  2108.   TCoolBar = class;
  2109.  
  2110.   TCoolBand = class(TCollectionItem)
  2111.   private
  2112.     FBorderStyle: TBorderStyle;
  2113.     FBreak: Boolean;
  2114.     FFixedSize: Boolean;
  2115.     FVisible: Boolean;
  2116.     FHorizontalOnly: Boolean;
  2117.     FImageIndex: Integer;
  2118.     FFixedBackground: Boolean;
  2119.     FMinHeight: Integer;
  2120.     FMinWidth: Integer;
  2121.     FColor: TColor;
  2122.     FControl: TWinControl;
  2123.     FParentColor: Boolean;
  2124.     FParentBitmap: Boolean;
  2125.     FBitmap: TBitmap;
  2126.     FText: string;
  2127.     FWidth: Integer;
  2128.     FDDB: TBitmap;
  2129.     FReplace: Boolean;
  2130.     function CoolBar: TCoolBar;
  2131.     function IsColorStored: Boolean;
  2132.     function IsBitmapStored: Boolean;
  2133.     procedure BitmapChanged(Sender: TObject);
  2134.     function GetHeight: Integer;
  2135.     procedure SetBorderStyle(Value: TBorderStyle);
  2136.     procedure SetBreak(Value: Boolean);
  2137.     procedure SetFixedSize(Value: Boolean);
  2138.     procedure SetMinHeight(Value: Integer);
  2139.     procedure SetMinWidth(Value: Integer);
  2140.     procedure SetVisible(Value: Boolean);
  2141.     procedure SetHorizontalOnly(Value: Boolean);
  2142.     procedure SetImageIndex(Value: Integer);
  2143.     procedure SetFixedBackground(Value: Boolean);
  2144.     procedure SetColor(Value: TColor);
  2145.     procedure SetControl(Value: TWinControl);
  2146.     procedure SetParentColor(Value: Boolean);
  2147.     procedure SetParentBitmap(Value: Boolean);
  2148.     procedure SetBitmap(Value: TBitmap);
  2149.     procedure SetText(const Value: string);
  2150.     procedure SetWidth(Value: Integer);
  2151.   protected
  2152.     function GetDisplayName: string; override;
  2153.     procedure ParentColorChanged; dynamic;
  2154.     procedure ParentBitmapChanged; dynamic;
  2155.   public
  2156.     constructor Create(Collection: TCollection); override;
  2157.     destructor Destroy; override;
  2158.     procedure Assign(Source: TPersistent); override;
  2159.     property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;
  2160.     property Height: Integer read GetHeight;
  2161.   published
  2162.     property Break: Boolean read FBreak write SetBreak default True;
  2163.     property Control: TWinControl read FControl write SetControl;
  2164.     property FixedSize: Boolean read FFixedSize write SetFixedSize default False;
  2165.     property Visible: Boolean read FVisible write SetVisible default True;
  2166.     property HorizontalOnly: Boolean read FHorizontalOnly write SetHorizontalOnly default False;
  2167.     property ImageIndex: Integer read FImageIndex write SetImageIndex;
  2168.     property FixedBackground: Boolean read FFixedBackground write SetFixedBackground default True;
  2169.     property MinHeight: Integer read FMinHeight write SetMinHeight default 26;
  2170.     property MinWidth: Integer read FMinWidth write SetMinWidth default 0;
  2171.     property Color: TColor read FColor write SetColor stored IsColorStored default clBtnFace;
  2172.     property ParentColor: Boolean read FParentColor write SetParentColor default True;
  2173.     property ParentBitmap: Boolean read FParentBitmap write SetParentBitmap default True;
  2174.     property Bitmap: TBitmap read FBitmap write SetBitmap stored IsBitmapStored;
  2175.     property Text: string read FText write SetText;
  2176.     property Width: Integer read FWidth write SetWidth;
  2177.   end;
  2178.  
  2179.   TCoolBands = class(TCollection)
  2180.   private
  2181.     FCoolBar: TCoolBar;
  2182.     FFixups: TStringList;
  2183.     FModified: Boolean;
  2184.     FUpdateCount: Integer;
  2185.     function GetItem(Index: Integer): TCoolBand;
  2186.     procedure SetItem(Index: Integer; Value: TCoolBand);
  2187.   protected
  2188.     function GetOwner: TPersistent; override;
  2189.     procedure Update(Item: TCollectionItem); override;
  2190.     function FindBand(AControl: TControl): TCoolBand;
  2191.     function HaveGraphic: Boolean;
  2192.   public
  2193.     constructor Create(CoolBar: TCoolBar);
  2194.     destructor Destroy; override;
  2195.     property CoolBar: TCoolBar read FCoolBar;
  2196.     property Items[Index: Integer]: TCoolBand read GetItem write SetItem; default;
  2197.   end;
  2198.  
  2199.   TCoolBar = class(TToolWindow)
  2200.   private
  2201.     FAutoSize: Boolean;
  2202.     FBands: TCoolBands;
  2203.     FBandBorderStyle: TBorderStyle;
  2204.     FBitmap: TBitmap;
  2205.     FDDB: TBitmap;
  2206.     FFixedSize: Boolean;
  2207.     FFixedOrder: Boolean;
  2208.     FImages: TImageList;
  2209.     FImageChangeLink: TChangeLink;
  2210.     FShowText: Boolean;
  2211.     FVertical: Boolean;
  2212.     FOnChange: TNotifyEvent;
  2213.     FOnResize: TNotifyEvent;
  2214.     procedure AdjustSize;
  2215.     procedure BitmapChanged(Sender: TObject);
  2216.     function GetAlign: TAlign;
  2217.     procedure SetAlign(Value: TAlign);
  2218.     procedure SetAutoSize(Value: Boolean);
  2219.     procedure SetBands(Value: TCoolBands);
  2220.     procedure SetBandBorderStyle(Value: TBorderStyle);
  2221.     procedure SetBitmap(Value: TBitmap);
  2222.     procedure SetFixedSize(Value: Boolean);
  2223.     procedure SetFixedOrder(Value: Boolean);
  2224.     procedure SetImageList(Value: HImageList);
  2225.     procedure SetImages(Value: TImageList);
  2226.     procedure SetShowText(Value: Boolean);
  2227.     procedure SetVertical(Value: Boolean);
  2228.     procedure ImageListChange(Sender: TObject);
  2229.     procedure ReplaceBand(Index: Integer);
  2230.     procedure InvalidateBand(Index: Integer);
  2231.     procedure UpdateBand(const Message, FromIndex, ToIndex: Integer);
  2232.     procedure RefreshBand(const Index: Integer);
  2233.     procedure UpdateBands;
  2234.     procedure ReadBands;
  2235.     function GetDisplaySize: Integer;
  2236.     function GetGripSize(Band: TCoolBand): Integer;
  2237.     function PtInGripRect(const Pos: TPoint): Boolean;
  2238.     procedure WMCaptureChanged(var Message: TMessage); message WM_CAPTURECHANGED;
  2239.     procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
  2240.     procedure WMSetCursor(var Message: TWMSetCursor); message WM_SETCURSOR;
  2241.     procedure WMSize(var Message: TWMSize); message WM_SIZE;
  2242.     procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED;
  2243.     procedure CMControlChange(var Message: TCMControlChange); message CM_CONTROLCHANGE;
  2244.     procedure CMDesignHitTest(var Message: TCMDesignHitTest); message CM_DESIGNHITTEST;
  2245.     procedure CMSysColorChange(var Message: TMessage); message CM_SYSCOLORCHANGE;
  2246.     procedure CMBandChange(var Message); message CM_BANDCHANGE;
  2247.     procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY;
  2248.   protected
  2249.     procedure AlignControls(AControl: TControl; var Rect: TRect); override;
  2250.     procedure Change; dynamic;
  2251.     procedure CreateParams(var Params: TCreateParams); override;
  2252.     procedure CreateWnd; override;
  2253.     function GetPalette: HPALETTE; override;
  2254.     procedure Loaded; override;
  2255.     procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  2256.     procedure Resize; dynamic;
  2257.     procedure WndProc(var Message: TMessage); override;
  2258.   public
  2259.     constructor Create(AOwner: TComponent); override;
  2260.     destructor Destroy; override;
  2261.   published
  2262.     property Align: TAlign read GetAlign write SetAlign default alTop;
  2263.     property AutoSize: Boolean read FAutoSize write SetAutoSize default False;
  2264.     property BandBorderStyle: TBorderStyle read FBandBorderStyle write SetBandBorderStyle default bsSingle;
  2265.     property Bands: TCoolBands read FBands write SetBands;
  2266.     property BorderStyle;
  2267.     property BorderWidth;
  2268.     property Color;
  2269.     property DragCursor;
  2270.     property DragMode;
  2271.     property Enabled;
  2272.     property FixedSize: Boolean read FFixedSize write SetFixedSize default False;
  2273.     property FixedOrder: Boolean read FFixedOrder write SetFixedOrder default False;
  2274.     property Font;
  2275.     property Images: TImageList read FImages write SetImages;
  2276.     property ParentColor;
  2277.     property ParentFont;
  2278.     property ParentShowHint;
  2279.     property Bitmap: TBitmap read FBitmap write SetBitmap;
  2280.     property PopupMenu;
  2281.     property ShowHint;
  2282.     property ShowText: Boolean read FShowText write SetShowText default True;
  2283.     property Vertical: Boolean read FVertical write SetVertical default False;
  2284.     property Visible;
  2285.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  2286.     property OnClick;
  2287.     property OnDblClick;
  2288.     property OnDragDrop;
  2289.     property OnDragOver;
  2290.     property OnEndDrag;
  2291.     property OnMouseDown;
  2292.     property OnMouseMove;
  2293.     property OnMouseUp;
  2294.     property OnResize: TNotifyEvent read FOnResize write FOnResize;
  2295.     property OnStartDrag;
  2296.   end;
  2297.  
  2298. type
  2299.   EDateTimeError = class(Exception);
  2300.  
  2301.   TDateTimeKind = (dtkDate, dtkTime);
  2302.   TDTDateMode = (dmComboBox, dmUpDown);
  2303.   TDTDateFormat = (dfShort, dfLong);
  2304.   TDTCalAlignment = (dtaLeft, dtaRight);
  2305.  
  2306.   TDTParseInputEvent = procedure(Sender: TObject; const UserString: string;
  2307.     var DateAndTime: TDateTime; var AllowChange: Boolean) of object;
  2308.  
  2309.   TDateTimePicker = class;
  2310.  
  2311.   TDateTimeColors = class(TPersistent)
  2312.   private
  2313.     Owner: TDateTimePicker;
  2314.     FBackColor: TColor;
  2315.     FTextColor: TColor;
  2316.     FTitleBackColor: TColor;
  2317.     FTitleTextColor: TColor;
  2318.     FMonthBackColor: TColor;
  2319.     FTrailingTextColor: TColor;
  2320.     procedure SetColor(Index: Integer; Value: TColor);
  2321.   public
  2322.     constructor Create(AOwner: TDateTimePicker);
  2323.     procedure Assign(Source: TPersistent); override;
  2324.     procedure SetAllColors;
  2325.   published
  2326.     property BackColor: TColor index 0 read FBackColor write SetColor default clWindow;
  2327.     property TextColor: TColor index 1 read FTextColor write SetColor default clWindowText;
  2328.     property TitleBackColor: TColor index 2 read FTitleBackColor write SetColor default clActiveCaption;
  2329.     property TitleTextColor: TColor index 3 read FTitleTextColor write SetColor default clWhite;
  2330.     property MonthBackColor: TColor index 4 read FMonthBackColor write SetColor default clWhite;
  2331.     property TrailingTextColor: TColor index 5read FTrailingTextColor
  2332.       write SetColor default clInactiveCaptionText;
  2333.   end;
  2334.  
  2335.   TDateTimePicker = class(TWinControl)
  2336.   private
  2337.     FCalAlignment: TDTCalAlignment;
  2338.     FCalColors: TDateTimeColors;
  2339.     FChecked: Boolean;
  2340.     FDateTime: TDateTime;
  2341.     FDateFormat: TDTDateFormat;
  2342.     FDateMode: TDTDateMode;
  2343.     FKind: TDateTimeKind;
  2344.     FParseInput: Boolean;
  2345.     FMaxDate: TDate;
  2346.     FMinDate: TDate;
  2347.     FShowCheckbox: Boolean;
  2348.     FOnUserInput: TDTParseInputEvent;
  2349.     FOnCloseUp: TNotifyEvent;
  2350.     FOnChange: TNotifyEvent;
  2351.     FOnDropDown: TNotifyEvent;
  2352.     procedure AdjustHeight;
  2353.     function GetDate: TDate;
  2354.     function GetTime: TTime;
  2355.     procedure SetCalAlignment(Value: TDTCalAlignment);
  2356.     procedure SetCalColors(Value: TDateTimeColors);
  2357.     procedure SetChecked(Value: Boolean);
  2358.     procedure SetDate(Value: TDate);
  2359.     procedure SetDateMode(Value: TDTDateMode);
  2360.     procedure SetDateFormat(Value: TDTDateFormat);
  2361.     procedure SetDateTime(Value: TDateTime);
  2362.     procedure SetKind(Value: TDateTimeKind);
  2363.     procedure SetParseInput(Value: Boolean);
  2364.     procedure SetMaxDate(Value: TDate);
  2365.     procedure SetMinDate(Value: TDate);
  2366.     procedure SetRange(MinVal, MaxVal: TDateTime);
  2367.     procedure SetShowCheckbox(Value: Boolean);
  2368.     procedure SetTime(Value: TTime);
  2369.     procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED;
  2370.     procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
  2371.     procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY;
  2372.   protected
  2373.     procedure CreateParams(var Params: TCreateParams); override;
  2374.     procedure CreateWnd; override;
  2375.   public
  2376.     constructor Create(AOwner: TComponent); override;
  2377.     destructor Destroy; override;
  2378.   published
  2379.     property CalAlignment: TDTCalAlignment read FCalAlignment write SetCalAlignment;
  2380.     property CalColors: TDateTimeColors read FCalColors write SetCalColors;
  2381.     // The Date, Time, ShowCheckbox, and Checked properties must be in this order:
  2382.     property Date: TDate read GetDate write SetDate;
  2383.     property Time: TTime read GetTime write SetTime;
  2384.     property ShowCheckbox: Boolean read FShowCheckbox write SetShowCheckbox default False;
  2385.     property Checked: Boolean read FChecked write SetChecked default True;
  2386.     property Color;
  2387.     property DateFormat: TDTDateFormat read FDateFormat write SetDateFormat;
  2388.     property DateMode: TDTDateMode read FDateMode write SetDateMode;
  2389.     property DragCursor;
  2390.     property DragMode;
  2391.     property Enabled;
  2392.     property Font;
  2393.     property ImeMode;
  2394.     property ImeName;
  2395.     property Kind: TDateTimeKind read FKind write SetKind;
  2396.     property MaxDate: TDate read FMaxDate write SetMaxDate;
  2397.     property MinDate: TDate read FMinDate write SetMinDate;
  2398.     property ParseInput: Boolean read FParseInput write SetParseInput;
  2399.     property ParentColor;
  2400.     property ParentFont;
  2401.     property ParentShowHint;
  2402.     property PopupMenu;
  2403.     property ShowHint;
  2404.     property TabStop default True;
  2405.     property Visible;
  2406.     property OnClick;
  2407.     property OnCloseUp: TNotifyEvent read FOnCloseUp write FOnCloseUp;
  2408.     property OnChange: TNotifyEvent read FOnChange write FOnChange;
  2409.     property OnDropDown: TNotifyEvent read FOnDropDown write FOnDropDown;
  2410.     property OnDblClick;
  2411.     property OnDragDrop;
  2412.     property OnDragOver;
  2413.     property OnEndDrag;
  2414.     property OnEnter;
  2415.     property OnExit;
  2416.     property OnKeyDown;
  2417.     property OnKeyPress;
  2418.     property OnKeyUp; 
  2419.     property OnStartDrag;
  2420.     property OnUserInput: TDTParseInputEvent read FOnUserInput write FOnUserInput;
  2421.   end;
  2422.  
  2423. function InitCommonControl(CC: Integer): Boolean;
  2424. procedure CheckCommonControl(CC: Integer);
  2425.  
  2426. implementation
  2427.  
  2428. uses Printers, Consts, ComStrs;
  2429.  
  2430. const
  2431.   SectionSizeArea = 8;
  2432.   RTFConversionFormat: TConversionFormat = (
  2433.     ConversionClass: TConversion;
  2434.     Extension: 'rtf';
  2435.     Next: nil);
  2436.   TextConversionFormat: TConversionFormat = (
  2437.     ConversionClass: TConversion;
  2438.     Extension: 'txt';
  2439.     Next: @RTFConversionFormat);
  2440.  
  2441. var
  2442.   ConversionFormatList: PConversionFormat = @TextConversionFormat;
  2443.   ShellModule: THandle;
  2444.  
  2445. function InitCommonControl(CC: Integer): Boolean;
  2446. var
  2447.   ICC: TInitCommonControlsEx;
  2448. begin
  2449.   ICC.dwSize := SizeOf(TInitCommonControlsEx);
  2450.   ICC.dwICC := CC;
  2451.   Result := InitCommonControlsEx(ICC);
  2452.   if not Result then InitCommonControls;
  2453. end;
  2454.  
  2455. procedure CheckCommonControl(CC: Integer);
  2456. begin
  2457.   if not InitCommonControl(CC) then
  2458.     raise EComponentError.Create(SInvalidComCtl32);
  2459. end;
  2460.  
  2461. { TTabStrings }
  2462.  
  2463. type
  2464.   TTabStrings = class(TStrings)
  2465.   private
  2466.     FTabControl: TCustomTabControl;
  2467.   protected
  2468.     function Get(Index: Integer): string; override;
  2469.     function GetCount: Integer; override;
  2470.     function GetObject(Index: Integer): TObject; override;
  2471.     procedure Put(Index: Integer; const S: string); override;
  2472.     procedure PutObject(Index: Integer; AObject: TObject); override;
  2473.     procedure SetUpdateState(Updating: Boolean); override;
  2474.   public
  2475.     procedure Clear; override;
  2476.     procedure Delete(Index: Integer); override;
  2477.     procedure Insert(Index: Integer; const S: string); override;
  2478.   end;
  2479.  
  2480. procedure TabControlError;
  2481. begin
  2482.   raise EListError.Create(sTabAccessError);
  2483. end;
  2484.  
  2485. procedure TTabStrings.Clear;
  2486. begin
  2487.   if SendMessage(FTabControl.Handle, TCM_DELETEALLITEMS, 0, 0) = 0 then
  2488.     TabControlError;
  2489.   FTabControl.TabsChanged;
  2490. end;
  2491.  
  2492. procedure TTabStrings.Delete(Index: Integer);
  2493. begin
  2494.   if SendMessage(FTabControl.Handle, TCM_DELETEITEM, Index, 0) = 0 then
  2495.     TabControlError;
  2496.   FTabControl.TabsChanged;
  2497. end;
  2498.  
  2499. function TTabStrings.Get(Index: Integer): string;
  2500. var
  2501.   TCItem: TTCItem;
  2502.   Buffer: array[0..4095] of Char;
  2503. begin
  2504.   TCItem.mask := TCIF_TEXT;
  2505.   TCItem.pszText := Buffer;
  2506.   TCItem.cchTextMax := SizeOf(Buffer);
  2507.   if SendMessage(FTabControl.Handle, TCM_GETITEM, Index,
  2508.     Longint(@TCItem)) = 0 then TabControlError;
  2509.   Result := Buffer;
  2510. end;
  2511.  
  2512. function TTabStrings.GetCount: Integer;
  2513. begin
  2514.   Result := SendMessage(FTabControl.Handle, TCM_GETITEMCOUNT, 0, 0);
  2515. end;
  2516.  
  2517. function TTabStrings.GetObject(Index: Integer): TObject;
  2518. var
  2519.   TCItem: TTCItem;
  2520. begin
  2521.   TCItem.mask := TCIF_PARAM;
  2522.   if SendMessage(FTabControl.Handle, TCM_GETITEM, Index,
  2523.     Longint(@TCItem)) = 0 then TabControlError;
  2524.   Result := TObject(TCItem.lParam);
  2525. end;
  2526.  
  2527. procedure TTabStrings.Put(Index: Integer; const S: string);
  2528. var
  2529.   TCItem: TTCItem;
  2530. begin
  2531.   TCItem.mask := TCIF_TEXT;
  2532.   TCItem.pszText := PChar(S);
  2533.   if SendMessage(FTabControl.Handle, TCM_SETITEM, Index,
  2534.     Longint(@TCItem)) = 0 then TabControlError;
  2535.   FTabControl.TabsChanged;
  2536. end;
  2537.  
  2538. procedure TTabStrings.PutObject(Index: Integer; AObject: TObject);
  2539. var
  2540.   TCItem: TTCItem;
  2541. begin
  2542.   TCItem.mask := TCIF_PARAM;
  2543.   TCItem.lParam := Longint(AObject);
  2544.   if SendMessage(FTabControl.Handle, TCM_SETITEM, Index,
  2545.     Longint(@TCItem)) = 0 then TabControlError;
  2546. end;
  2547.  
  2548. procedure TTabStrings.Insert(Index: Integer; const S: string);
  2549. var
  2550.   TCItem: TTCItem;
  2551. begin
  2552.   TCItem.mask := TCIF_TEXT;
  2553.   TCItem.pszText := PChar(S);
  2554.   if SendMessage(FTabControl.Handle, TCM_INSERTITEM, Index,
  2555.     Longint(@TCItem)) < 0 then TabControlError;
  2556.   FTabControl.TabsChanged;
  2557. end;
  2558.  
  2559. procedure TTabStrings.SetUpdateState(Updating: Boolean);
  2560. begin
  2561.   FTabControl.FUpdating := Updating;
  2562.   SendMessage(FTabControl.Handle, WM_SETREDRAW, Ord(not Updating), 0);
  2563.   if not Updating then
  2564.   begin
  2565.     FTabControl.Invalidate;
  2566.     FTabControl.TabsChanged;
  2567.   end;
  2568. end;
  2569.  
  2570. { TCustomTabControl }
  2571.  
  2572. constructor TCustomTabControl.Create(AOwner: TComponent);
  2573. begin
  2574.   inherited Create(AOwner);
  2575.   Width := 289;
  2576.   Height := 193;
  2577.   TabStop := True;
  2578.   ControlStyle := [csAcceptsControls, csDoubleClicks, csOpaque];
  2579.   FTabs := TTabStrings.Create;
  2580.   TTabStrings(FTabs).FTabControl := Self;
  2581. end;
  2582.  
  2583. destructor TCustomTabControl.Destroy;
  2584. begin
  2585.   FTabs.Free;
  2586.   FSaveTabs.Free;
  2587.   inherited Destroy;
  2588. end;
  2589.  
  2590. function TCustomTabControl.CanChange: Boolean;
  2591. begin
  2592.   Result := True;
  2593.   if Assigned(FOnChanging) then FOnChanging(Self, Result);
  2594. end;
  2595.  
  2596. procedure TCustomTabControl.Change;
  2597. begin
  2598.   if Assigned(FOnChange) then FOnChange(Self);
  2599. end;
  2600.  
  2601. procedure TCustomTabControl.CreateParams(var Params: TCreateParams);
  2602. const
  2603.   AlignStyles:array[TTabPosition] of Integer = (
  2604.     0, TCS_BOTTOM{, TCS_VERTICAL, TCS_VERTICAL or TCS_RIGHT});
  2605. begin
  2606.   InitCommonControl(ICC_TAB_CLASSES);
  2607.   inherited CreateParams(Params);
  2608.   CreateSubClass(Params, WC_TABCONTROL);
  2609.   with Params do
  2610.   begin
  2611.     Style := Style or WS_CLIPCHILDREN or AlignStyles[FTabPosition];
  2612.     if not TabStop then Style := Style or TCS_FOCUSNEVER;
  2613.     if FMultiLine then Style := Style or TCS_MULTILINE;
  2614.     if FTabSize.X <> 0 then Style := Style or TCS_FIXEDWIDTH;
  2615.     if FHotTrack and (not (csDesigning in ComponentState)) then
  2616.       Style := Style or TCS_HOTTRACK;
  2617.     if FScrollOpposite then Style := Style or TCS_SCROLLOPPOSITE;
  2618.     WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW) or
  2619.       CS_DBLCLKS;
  2620.   end;
  2621. end;
  2622.  
  2623. procedure TCustomTabControl.CreateWnd;
  2624. begin
  2625.   inherited CreateWnd;
  2626.   if Integer(FTabSize) <> 0 then UpdateTabSize;
  2627.   if FSaveTabs <> nil then
  2628.   begin
  2629.     FTabs.Assign(FSaveTabs);
  2630.     SetTabIndex(FSaveTabIndex);
  2631.     FSaveTabs.Free;
  2632.     FSaveTabs := nil;
  2633.   end;
  2634. end;
  2635.  
  2636. procedure TCustomTabControl.DestroyWnd;
  2637. begin
  2638.   if FTabs.Count > 0 then
  2639.   begin
  2640.     FSaveTabs := TStringList.Create;
  2641.     FSaveTabs.Assign(FTabs);
  2642.     FSaveTabIndex := GetTabIndex;
  2643.   end;
  2644.   inherited DestroyWnd;
  2645. end;
  2646.  
  2647. procedure TCustomTabControl.AlignControls(AControl: TControl;
  2648.   var Rect: TRect);
  2649. begin
  2650.   Rect := DisplayRect;
  2651.   inherited AlignControls(AControl, Rect);
  2652. end;
  2653.  
  2654. function TCustomTabControl.GetDisplayRect: TRect;
  2655. begin
  2656.   Result := ClientRect;
  2657.   SendMessage(Handle, TCM_ADJUSTRECT, 0, Integer(@Result));
  2658.   Inc(Result.Top, 2);
  2659. end;
  2660.  
  2661. function TCustomTabControl.GetTabIndex: Integer;
  2662. begin
  2663.   Result := SendMessage(Handle, TCM_GETCURSEL, 0, 0);
  2664. end;
  2665.  
  2666. procedure TCustomTabControl.SetHotTrack(Value: Boolean);
  2667. begin
  2668.   if FHotTrack <> Value then
  2669.   begin
  2670.     FHotTrack := Value;
  2671.     RecreateWnd;
  2672.   end;
  2673. end;
  2674.  
  2675. procedure TCustomTabControl.SetMultiLine(Value: Boolean);
  2676. begin
  2677.   if FMultiLine <> Value then
  2678.   begin
  2679.     FMultiLine := Value;
  2680.     if not Value then FScrollOpposite := Value;
  2681.     RecreateWnd;
  2682.   end;
  2683. end;
  2684.  
  2685. procedure TCustomTabControl.SetScrollOpposite(Value: Boolean);
  2686. begin
  2687.   if FScrollOpposite <> Value then
  2688.   begin
  2689.     FScrollOpposite := Value;
  2690.     if Value then FMultiLine := Value;
  2691.     RecreateWnd;
  2692.   end;
  2693. end;
  2694.  
  2695. procedure TCustomTabControl.SetTabHeight(Value: Smallint);
  2696. begin
  2697.   if FTabSize.Y <> Value then
  2698.   begin
  2699.     if Value < 0 then
  2700.       raise EInvalidOperation.CreateFmt(SPropertyOutOfRange, [Self.Classname]);
  2701.     FTabSize.Y := Value;
  2702.     UpdateTabSize;
  2703.   end;
  2704. end;
  2705.  
  2706. procedure TCustomTabControl.SetTabIndex(Value: Integer);
  2707. begin
  2708.   SendMessage(Handle, TCM_SETCURSEL, Value, 0);
  2709. end;
  2710.  
  2711. procedure TCustomTabControl.SetTabPosition(Value: TTabPosition);
  2712. begin
  2713.   if FTabPosition <> Value then
  2714.   begin
  2715.     FTabPosition := Value;
  2716.     RecreateWnd;
  2717.   end;
  2718. end;
  2719.  
  2720. procedure TCustomTabControl.SetTabs(Value: TStrings);
  2721. begin
  2722.   FTabs.Assign(Value);
  2723. end;
  2724.  
  2725. procedure TCustomTabControl.SetTabWidth(Value: Smallint);
  2726. var
  2727.   OldValue: Smallint;
  2728. begin
  2729.   if FTabSize.X <> Value then
  2730.   begin
  2731.     if Value < 0 then
  2732.       raise EInvalidOperation.CreateFmt(SPropertyOutOfRange, [Self.Classname]);
  2733.     OldValue := FTabSize.X;
  2734.     FTabSize.X := Value;
  2735.     if (OldValue = 0) or (Value = 0) then
  2736.       RecreateWnd else
  2737.       UpdateTabSize;
  2738.   end;
  2739. end;
  2740.  
  2741. procedure TCustomTabControl.TabsChanged;
  2742. begin
  2743.   if not FUpdating then
  2744.   begin
  2745.     if HandleAllocated then
  2746.       SendMessage(Handle, WM_SIZE, SIZE_RESTORED,
  2747.         Word(Width) or Word(Height) shl 16);
  2748.     Realign;
  2749.   end;
  2750. end;
  2751.  
  2752. procedure TCustomTabControl.UpdateTabSize;
  2753. begin
  2754.   SendMessage(Handle, TCM_SETITEMSIZE, 0, Integer(FTabSize));
  2755.   TabsChanged;
  2756. end;
  2757.  
  2758. procedure TCustomTabControl.WMDestroy(var Message: TWMDestroy);
  2759. var
  2760.   FocusHandle: HWnd;
  2761. begin
  2762.   FocusHandle := GetFocus;
  2763.   if (FocusHandle <> 0) and ((FocusHandle = Handle) or
  2764.     IsChild(Handle, FocusHandle)) then
  2765.     Windows.SetFocus(0);
  2766.   inherited;
  2767. end;
  2768.  
  2769. procedure TCustomTabControl.WMEraseBkgnd(var Message: TMessage);
  2770. begin
  2771. // This is here in-case FDoubleBuffered is enabled
  2772.   if FDoubleBuffered and (Message.wParam <> Message.lParam) then Message.Result := 1
  2773.   else inherited;
  2774. end;
  2775.  
  2776. procedure TCustomTabControl.WMSize(var Message: TMessage);
  2777. begin
  2778.   inherited;
  2779.   RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_ERASE);
  2780. end;
  2781.  
  2782. procedure TCustomTabControl.CMFontChanged(var Message);
  2783. begin
  2784.   inherited;
  2785.   if HandleAllocated then Perform(WM_SIZE, 0, 0);
  2786. end;
  2787.  
  2788. procedure TCustomTabControl.CMSysColorChange(var Message: TMessage);
  2789. begin
  2790.   inherited;
  2791.   if not (csLoading in ComponentState) then
  2792.   begin
  2793.     Message.Msg := WM_SYSCOLORCHANGE;
  2794.     DefaultHandler(Message);
  2795.   end;
  2796. end;
  2797.  
  2798. procedure TCustomTabControl.CMTabStopChanged(var Message: TMessage);
  2799. begin
  2800.   if not (csDesigning in ComponentState) then RecreateWnd;
  2801. end;
  2802.  
  2803. procedure TCustomTabControl.CNNotify(var Message: TWMNotify);
  2804. begin
  2805.   with Message.NMHdr^ do
  2806.     case code of
  2807.       TCN_SELCHANGE:
  2808.         Change;
  2809.       TCN_SELCHANGING:
  2810.         begin
  2811.           Message.Result := 1;
  2812.           if CanChange then Message.Result := 0;
  2813.         end;
  2814.     end;
  2815. end;
  2816.  
  2817. { TTabSheet }
  2818.  
  2819. constructor TTabSheet.Create(AOwner: TComponent);
  2820. begin
  2821.   inherited Create(AOwner);
  2822.   Align := alClient;
  2823.   ControlStyle := ControlStyle + [csAcceptsControls, csNoDesignVisible];
  2824.   Visible := False;
  2825.   FTabVisible := True;
  2826. end;
  2827.  
  2828. destructor TTabSheet.Destroy;
  2829. begin
  2830.   if FPageControl <> nil then FPageControl.RemovePage(Self);
  2831.   inherited Destroy;
  2832. end;
  2833.  
  2834. function TTabSheet.GetPageIndex: Integer;
  2835. begin
  2836.   if FPageControl <> nil then
  2837.     Result := FPageControl.FPages.IndexOf(Self) else
  2838.     Result := -1;
  2839. end;
  2840.  
  2841. function TTabSheet.GetTabIndex: Integer;
  2842. var
  2843.   I: Integer;
  2844. begin
  2845.   Result := 0;
  2846.   if not FTabShowing then Dec(Result) else
  2847.     for I := 0 to PageIndex - 1 do
  2848.       if TTabSheet(FPageControl.FPages[I]).FTabShowing then
  2849.         Inc(Result);
  2850. end;
  2851.  
  2852. procedure TTabSheet.CreateParams(var Params: TCreateParams);
  2853. begin
  2854.   inherited CreateParams(Params);
  2855.   with Params.WindowClass do
  2856.     style := style and not (CS_HREDRAW or CS_VREDRAW);
  2857. end;
  2858.  
  2859. procedure TTabSheet.ReadState(Reader: TReader);
  2860. begin
  2861.   inherited ReadState(Reader);
  2862.   if Reader.Parent is TPageControl then
  2863.     PageControl := TPageControl(Reader.Parent);
  2864. end;
  2865.  
  2866. procedure TTabSheet.SetPageControl(APageControl: TPageControl);
  2867. begin
  2868.   if FPageControl <> APageControl then
  2869.   begin
  2870.     if FPageControl <> nil then FPageControl.RemovePage(Self);
  2871.     Parent := APageControl;
  2872.     if APageControl <> nil then APageControl.InsertPage(Self);
  2873.   end;
  2874. end;
  2875.  
  2876. procedure TTabSheet.SetPageIndex(Value: Integer);
  2877. var
  2878.   I, MaxPageIndex: Integer;
  2879. begin
  2880.   if FPageControl <> nil then
  2881.   begin
  2882.     MaxPageIndex := FPageControl.FPages.Count - 1;
  2883.     if Value > MaxPageIndex then
  2884.       raise EListError.CreateFmt(SPageIndexError, [Value, MaxPageIndex]);
  2885.     I := TabIndex;
  2886.     FPageControl.FPages.Move(PageIndex, Value);
  2887.     if I >= 0 then FPageControl.MoveTab(I, TabIndex);
  2888.   end;
  2889. end;
  2890.  
  2891. procedure TTabSheet.SetTabShowing(Value: Boolean);
  2892. begin
  2893.   if FTabShowing <> Value then
  2894.     if Value then
  2895.     begin
  2896.       FTabShowing := True;
  2897.       FPageControl.InsertTab(Self);
  2898.     end else
  2899.     begin
  2900.       FPageControl.DeleteTab(Self);
  2901.       FTabShowing := False;
  2902.     end;
  2903. end;
  2904.  
  2905. procedure TTabSheet.SetTabVisible(Value: Boolean);
  2906. begin
  2907.   if FTabVisible <> Value then
  2908.   begin
  2909.     FTabVisible := Value;
  2910.     UpdateTabShowing;
  2911.   end;
  2912. end;
  2913.  
  2914. procedure TTabSheet.UpdateTabShowing;
  2915. begin
  2916.   SetTabShowing((FPageControl <> nil) and FTabVisible);
  2917. end;
  2918.  
  2919. procedure TTabSheet.CMTextChanged(var Message: TMessage);
  2920. begin
  2921.   if FTabShowing then FPageControl.UpdateTab(Self);
  2922. end;
  2923.  
  2924. { TPageControl }
  2925.  
  2926. constructor TPageControl.Create(AOwner: TComponent);
  2927. begin
  2928.   inherited Create(AOwner);
  2929.   ControlStyle := [csDoubleClicks];
  2930.   FPages := TList.Create;
  2931. end;
  2932.  
  2933. destructor TPageControl.Destroy;
  2934. var
  2935.   I: Integer;
  2936. begin
  2937.   for I := 0 to FPages.Count - 1 do TTabSheet(FPages[I]).FPageControl := nil;
  2938.   FPages.Free;
  2939.   inherited Destroy;
  2940. end;
  2941.  
  2942. procedure TPageControl.Change;
  2943. var
  2944.   Form: TCustomForm;
  2945. begin
  2946.   UpdateActivePage;
  2947.   if csDesigning in ComponentState then
  2948.   begin
  2949.     Form := GetParentForm(Self);
  2950.     if (Form <> nil) and (Form.Designer <> nil) then Form.Designer.Modified;
  2951.   end;
  2952.   inherited Change;
  2953. end;
  2954.  
  2955. procedure TPageControl.ChangeActivePage(Page: TTabSheet);
  2956. var
  2957.   ParentForm: TCustomForm;
  2958. begin
  2959.   if FActivePage <> Page then
  2960.   begin
  2961.     ParentForm := GetParentForm(Self);
  2962.     if (ParentForm <> nil) and (FActivePage <> nil) and
  2963.       FActivePage.ContainsControl(ParentForm.ActiveControl) then
  2964.       ParentForm.ActiveControl := FActivePage;
  2965.     if Page <> nil then
  2966.     begin
  2967.       Page.BringToFront;
  2968.       Page.Visible := True;
  2969.       if (ParentForm <> nil) and (FActivePage <> nil) and
  2970.         (ParentForm.ActiveControl = FActivePage) then
  2971.         if Page.CanFocus then
  2972.           ParentForm.ActiveControl := Page else
  2973.           ParentForm.ActiveControl := Self;
  2974.     end;
  2975.     if FActivePage <> nil then FActivePage.Visible := False;
  2976.     FActivePage := Page;
  2977.     if (ParentForm <> nil) and (FActivePage <> nil) and
  2978.       (ParentForm.ActiveControl = FActivePage) then
  2979.       FActivePage.SelectFirst;
  2980.   end;
  2981. end;
  2982.  
  2983. procedure TPageControl.DeleteTab(Page: TTabSheet);
  2984. begin
  2985.   Tabs.Delete(Page.TabIndex);
  2986.   UpdateActivePage;
  2987. end;
  2988.  
  2989. function TPageControl.FindNextPage(CurPage: TTabSheet;
  2990.   GoForward, CheckTabVisible: Boolean): TTabSheet;
  2991. var
  2992.   I, StartIndex: Integer;
  2993. begin
  2994.   if FPages.Count <> 0 then
  2995.   begin
  2996.     StartIndex := FPages.IndexOf(CurPage);
  2997.     if StartIndex = -1 then
  2998.       if GoForward then StartIndex := FPages.Count - 1 else StartIndex := 0;
  2999.     I := StartIndex;
  3000.     repeat
  3001.       if GoForward then
  3002.       begin
  3003.         Inc(I);
  3004.         if I = FPages.Count then I := 0;
  3005.       end else
  3006.       begin
  3007.         if I = 0 then I := FPages.Count;
  3008.         Dec(I);
  3009.       end;
  3010.       Result := FPages[I];
  3011.       if not CheckTabVisible or Result.TabVisible then Exit;
  3012.     until I = StartIndex;
  3013.   end;
  3014.   Result := nil;
  3015. end;
  3016.  
  3017. procedure TPageControl.GetChildren(Proc: TGetChildProc; Root: TComponent);
  3018. var
  3019.   I: Integer;
  3020. begin
  3021.   for I := 0 to FPages.Count - 1 do Proc(TComponent(FPages[I]));
  3022. end;
  3023.  
  3024. function TPageControl.GetPage(Index: Integer): TTabSheet;
  3025. begin
  3026.   Result := FPages[Index];
  3027. end;
  3028.  
  3029. function TPageControl.GetPageCount: Integer;
  3030. begin
  3031.   Result := FPages.Count;
  3032. end;
  3033.  
  3034. procedure TPageControl.InsertPage(Page: TTabSheet);
  3035. begin
  3036.   FPages.Add(Page);
  3037.   Page.FPageControl := Self;
  3038.   Page.UpdateTabShowing;
  3039. end;
  3040.  
  3041. procedure TPageControl.InsertTab(Page: TTabSheet);
  3042. begin
  3043.   Tabs.InsertObject(Page.TabIndex, Page.Caption, Page);
  3044.   UpdateActivePage;
  3045. end;
  3046.  
  3047. procedure TPageControl.MoveTab(CurIndex, NewIndex: Integer);
  3048. begin
  3049.   Tabs.Move(CurIndex, NewIndex);
  3050. end;
  3051.  
  3052. procedure TPageControl.RemovePage(Page: TTabSheet);
  3053. begin
  3054.   if FActivePage = Page then SetActivePage(nil);
  3055.   Page.SetTabShowing(False);
  3056.   Page.FPageControl := nil;
  3057.   FPages.Remove(Page);
  3058. end;
  3059.  
  3060. procedure TPageControl.SelectNextPage(GoForward: Boolean);
  3061. var
  3062.   Page: TTabSheet;
  3063. begin
  3064.   Page := FindNextPage(ActivePage, GoForward, True);
  3065.   if (Page <> nil) and (Page <> ActivePage) and CanChange then
  3066.   begin
  3067.     TabIndex := Page.TabIndex;
  3068.     Change;
  3069.   end;
  3070. end;
  3071.  
  3072. procedure TPageControl.SetActivePage(Page: TTabSheet);
  3073. begin
  3074.   if (Page <> nil) and (Page.PageControl <> Self) then Exit;
  3075.   ChangeActivePage(Page);
  3076.   if Page <> nil then TabIndex := Page.TabIndex else TabIndex := -1;
  3077. end;
  3078.  
  3079. procedure TPageControl.SetChildOrder(Child: TComponent; Order: Integer);
  3080. begin
  3081.   TTabSheet(Child).PageIndex := Order;
  3082. end;
  3083.  
  3084. procedure TPageControl.ShowControl(AControl: TControl);
  3085. begin
  3086.   if (AControl is TTabSheet) and (TTabSheet(AControl).PageControl = Self) then
  3087.     SetActivePage(TTabSheet(AControl));
  3088.   inherited ShowControl(AControl);
  3089. end;
  3090.  
  3091. procedure TPageControl.UpdateTab(Page: TTabSheet);
  3092. begin
  3093.   Tabs[Page.TabIndex] := Page.Caption;
  3094. end;
  3095.  
  3096. procedure TPageControl.UpdateActivePage;
  3097. begin
  3098.   if TabIndex >= 0 then SetActivePage(TTabSheet(Tabs.Objects[TabIndex]));
  3099. end;
  3100.  
  3101. procedure TPageControl.CMDesignHitTest(var Message: TCMDesignHitTest);
  3102. var
  3103.   HitIndex: Integer;
  3104.   HitTestInfo: TTCHitTestInfo;
  3105. begin
  3106.   HitTestInfo.pt := SmallPointToPoint(Message.Pos);
  3107.   HitIndex := SendMessage(Handle, TCM_HITTEST, 0, Longint(@HitTestInfo));
  3108.   if (HitIndex >= 0) and (HitIndex <> TabIndex) then Message.Result := 1;
  3109. end;
  3110.  
  3111. procedure TPageControl.CMDialogKey(var Message: TCMDialogKey);
  3112. begin
  3113.   if (Message.CharCode = VK_TAB) and (GetKeyState(VK_CONTROL) < 0) then
  3114.   begin
  3115.     SelectNextPage(GetKeyState(VK_SHIFT) >= 0);
  3116.     Message.Result := 1;
  3117.   end else
  3118.     inherited;
  3119. end;
  3120.  
  3121. { TStatusPanel }
  3122.  
  3123. constructor TStatusPanel.Create(Collection: TCollection);
  3124. begin
  3125.   FWidth := 50;
  3126.   FBevel := pbLowered;
  3127.   inherited Create(Collection);
  3128. end;
  3129.  
  3130. procedure TStatusPanel.Assign(Source: TPersistent);
  3131. begin
  3132.   if Source is TStatusPanel then
  3133.   begin
  3134.     Text := TStatusPanel(Source).Text;
  3135.     Width := TStatusPanel(Source).Width;
  3136.     Alignment := TStatusPanel(Source).Alignment;
  3137.     Bevel := TStatusPanel(Source).Bevel;
  3138.     Style := TStatusPanel(Source).Style;
  3139.     Exit;
  3140.   end;
  3141.   inherited Assign(Source);
  3142. end;
  3143.  
  3144. function TStatusPanel.GetDisplayName: string;
  3145. begin
  3146.   Result := Text;
  3147.   if Result = '' then Result := inherited GetDisplayName;
  3148. end;
  3149.  
  3150. procedure TStatusPanel.SetAlignment(Value: TAlignment);
  3151. begin
  3152.   if FAlignment <> Value then
  3153.   begin
  3154.     FAlignment := Value;
  3155.     Changed(False);
  3156.   end;
  3157. end;
  3158.  
  3159. procedure TStatusPanel.SetBevel(Value: TStatusPanelBevel);
  3160. begin
  3161.   if FBevel <> Value then
  3162.   begin
  3163.     FBevel := Value;
  3164.     Changed(True);
  3165.   end;
  3166. end;
  3167.  
  3168. procedure TStatusPanel.SetStyle(Value: TStatusPanelStyle);
  3169. begin
  3170.   if FStyle <> Value then
  3171.   begin
  3172.     FStyle := Value;
  3173.     Changed(False);
  3174.   end;
  3175. end;
  3176.  
  3177. procedure TStatusPanel.SetText(const Value: string);
  3178. begin
  3179.   if FText <> Value then
  3180.   begin
  3181.     FText := Value;
  3182.     Changed(False);
  3183.   end;
  3184. end;
  3185.  
  3186. procedure TStatusPanel.SetWidth(Value: Integer);
  3187. begin
  3188.   if FWidth <> Value then
  3189.   begin
  3190.     FWidth := Value;
  3191.     Changed(True);
  3192.   end;
  3193. end;
  3194.  
  3195. { TStatusPanels }
  3196.  
  3197. constructor TStatusPanels.Create(StatusBar: TStatusBar);
  3198. begin
  3199.   inherited Create(TStatusPanel);
  3200.   FStatusBar := StatusBar;
  3201. end;
  3202.  
  3203. function TStatusPanels.Add: TStatusPanel;
  3204. begin
  3205.   Result := TStatusPanel(inherited Add);
  3206. end;
  3207.  
  3208. function TStatusPanels.GetItem(Index: Integer): TStatusPanel;
  3209. begin
  3210.   Result := TStatusPanel(inherited GetItem(Index));
  3211. end;
  3212.  
  3213. function TStatusPanels.GetOwner: TPersistent;
  3214. begin
  3215.   Result := FStatusBar;
  3216. end;
  3217.  
  3218. procedure TStatusPanels.SetItem(Index: Integer; Value: TStatusPanel);
  3219. begin
  3220.   inherited SetItem(Index, Value);
  3221. end;
  3222.  
  3223. procedure TStatusPanels.Update(Item: TCollectionItem);
  3224. begin
  3225.   if Item <> nil then
  3226.     FStatusBar.UpdatePanel(Item.Index) else
  3227.     FStatusBar.UpdatePanels;
  3228. end;
  3229.  
  3230. { TStatusBar }
  3231.  
  3232. constructor TStatusBar.Create(AOwner: TComponent);
  3233. begin
  3234.   inherited Create(AOwner);
  3235.   ControlStyle := [csCaptureMouse, csClickEvents, csDoubleClicks, csOpaque];
  3236.   Color := clBtnFace;
  3237.   Height := 19;
  3238.   Align := alBottom;
  3239.   FPanels := TStatusPanels.Create(Self);
  3240.   FCanvas := TControlCanvas.Create;
  3241.   TControlCanvas(FCanvas).Control := Self;
  3242.   FSizeGrip := True;
  3243. end;
  3244.  
  3245. destructor TStatusBar.Destroy;
  3246. begin
  3247.   FCanvas.Free;
  3248.   FPanels.Free;
  3249.   inherited Destroy;
  3250. end;
  3251.  
  3252. procedure TStatusBar.CreateParams(var Params: TCreateParams);
  3253. begin
  3254.   InitCommonControl(ICC_BAR_CLASSES);
  3255.   inherited CreateParams(Params);
  3256.   CreateSubClass(Params, STATUSCLASSNAME);
  3257.   with Params do
  3258.   begin
  3259.     if FSizeGrip then
  3260.       Style := Style or SBARS_SIZEGRIP else
  3261.       Style := Style or CCS_TOP;
  3262.     WindowClass.style := WindowClass.style and not CS_HREDRAW;
  3263.   end;
  3264. end;
  3265.  
  3266. procedure TStatusBar.CreateWnd;
  3267. begin
  3268.   inherited CreateWnd;
  3269.   UpdatePanels;
  3270.   if FSimpleText <> '' then
  3271.     SendMessage(Handle, SB_SETTEXT, 255, Integer(PChar(FSimpleText)));
  3272.   if FSimplePanel then
  3273.     SendMessage(Handle, SB_SIMPLE, 1, 0);
  3274. end;
  3275.  
  3276. procedure TStatusBar.DrawPanel(Panel: TStatusPanel; const Rect: TRect);
  3277. begin
  3278.   if Assigned(FOnDrawPanel) then
  3279.     FOnDrawPanel(Self, Panel, Rect) else
  3280.     FCanvas.FillRect(Rect);
  3281. end;
  3282.  
  3283. procedure TStatusBar.Resize;
  3284. begin
  3285.   if Assigned(FOnResize) then FOnResize(Self);
  3286. end;
  3287.  
  3288. procedure TStatusBar.SetPanels(Value: TStatusPanels);
  3289. begin
  3290.   FPanels.Assign(Value);
  3291. end;
  3292.  
  3293. procedure TStatusBar.SetSimplePanel(Value: Boolean);
  3294. begin
  3295.   if FSimplePanel <> Value then
  3296.   begin
  3297.     FSimplePanel := Value;
  3298.     if HandleAllocated then
  3299.       SendMessage(Handle, SB_SIMPLE, Ord(FSimplePanel), 0);
  3300.   end;
  3301. end;
  3302.  
  3303. procedure TStatusBar.SetSimpleText(const Value: string);
  3304. begin
  3305.   if FSimpleText <> Value then
  3306.   begin
  3307.     FSimpleText := Value;
  3308.     if HandleAllocated then
  3309.       SendMessage(Handle, SB_SETTEXT, 255, Integer(PChar(FSimpleText)));
  3310.   end;
  3311. end;
  3312.  
  3313. procedure TStatusBar.SetSizeGrip(Value: Boolean);
  3314. begin
  3315.   if FSizeGrip <> Value then
  3316.   begin
  3317.     FSizeGrip := Value;
  3318.     RecreateWnd;
  3319.   end;
  3320. end;
  3321.  
  3322. procedure TStatusBar.UpdatePanel(Index: Integer);
  3323. var
  3324.   Flags: Integer;
  3325.   S: string;
  3326. begin
  3327.   if HandleAllocated then
  3328.     with Panels[Index] do
  3329.     begin
  3330.       Flags := 0;
  3331.       case Bevel of
  3332.         pbNone: Flags := SBT_NOBORDERS;
  3333.         pbRaised: Flags := SBT_POPOUT;
  3334.       end;
  3335.       if Style = psOwnerDraw then Flags := Flags or SBT_OWNERDRAW;
  3336.       S := Text;
  3337.       case Alignment of
  3338.         taCenter: S := #9 + S;
  3339.         taRightJustify: S := #9#9 + S;
  3340.       end;
  3341.       SendMessage(Handle, SB_SETTEXT, Index or Flags, Integer(PChar(S)));
  3342.       InvalidateRect(Handle, Nil, True);
  3343.     end;
  3344. end;
  3345.  
  3346. procedure TStatusBar.UpdatePanels;
  3347. const
  3348.   MaxPanelCount = 128;
  3349. var
  3350.   I, Count, PanelPos: Integer;
  3351.   PanelEdges: array[0..MaxPanelCount - 1] of Integer;
  3352. begin
  3353.   if HandleAllocated then
  3354.   begin
  3355.     Count := Panels.Count;
  3356.     if Count > MaxPanelCount then Count := MaxPanelCount;
  3357.     if Count = 0 then
  3358.     begin
  3359.       PanelEdges[0] := -1;
  3360.       SendMessage(Handle, SB_SETPARTS, 1, Integer(@PanelEdges));
  3361.       SendMessage(Handle, SB_SETTEXT, 0, Integer(PChar('')));
  3362.     end else
  3363.     begin
  3364.       PanelPos := 0;
  3365.       for I := 0 to Count - 2 do
  3366.       begin
  3367.         Inc(PanelPos, Panels[I].Width);
  3368.         PanelEdges[I] := PanelPos;
  3369.       end;
  3370.       PanelEdges[Count - 1] := -1;
  3371.       SendMessage(Handle, SB_SETPARTS, Count, Integer(@PanelEdges));
  3372.       for I := 0 to Count - 1 do UpdatePanel(I);
  3373.     end;
  3374.   end;
  3375. end;
  3376.  
  3377. procedure TStatusBar.CNDrawItem(var Message: TWMDrawItem);
  3378. var
  3379.   SaveIndex: Integer;
  3380. begin
  3381.   with Message.DrawItemStruct^ do
  3382.   begin
  3383.     SaveIndex := SaveDC(hDC);
  3384.     FCanvas.Handle := hDC;
  3385.     FCanvas.Font := Font;
  3386.     FCanvas.Brush.Color := clBtnFace;
  3387.     FCanvas.Brush.Style := bsSolid;
  3388.     DrawPanel(Panels[itemID], rcItem);
  3389.     FCanvas.Handle := 0;
  3390.     RestoreDC(hDC, SaveIndex);
  3391.   end;
  3392.   Message.Result := 1;
  3393. end;
  3394.  
  3395. procedure TStatusBar.WMSize(var Message: TWMSize);
  3396. begin
  3397.   { Eat WM_SIZE message to prevent control from doing alignment }
  3398.   if not (csLoading in ComponentState) then Resize;
  3399.   Repaint;
  3400. end;
  3401.  
  3402. { THeaderSection }
  3403.  
  3404. constructor THeaderSection.Create(Collection: TCollection);
  3405. begin
  3406.   FWidth := 50;
  3407.   FMaxWidth := 10000;
  3408.   FAllowClick := True;
  3409.   inherited Create(Collection);
  3410. end;
  3411.  
  3412. procedure THeaderSection.Assign(Source: TPersistent);
  3413. begin
  3414.   if Source is THeaderSection then
  3415.   begin
  3416.     Text := THeaderSection(Source).Text;
  3417.     Width := THeaderSection(Source).Width;
  3418.     MinWidth := THeaderSection(Source).MinWidth;
  3419.     MaxWidth := THeaderSection(Source).MaxWidth;
  3420.     Alignment := THeaderSection(Source).Alignment;
  3421.     Style := THeaderSection(Source).Style;
  3422.     AllowClick := THeaderSection(Source).AllowClick;
  3423.     Exit;
  3424.   end;
  3425.   inherited Assign(Source);
  3426. end;
  3427.  
  3428. function THeaderSection.GetDisplayName: string;
  3429. begin
  3430.   Result := Text;
  3431.   if Result = '' then Result := inherited GetDisplayName;
  3432. end;
  3433.  
  3434. function THeaderSection.GetLeft: Integer;
  3435. var
  3436.   I: Integer;
  3437. begin
  3438.   Result := 0;
  3439.   for I := 0 to Index - 1 do
  3440.     Inc(Result, THeaderSections(Collection)[I].Width);
  3441. end;
  3442.  
  3443. function THeaderSection.GetRight: Integer;
  3444. begin
  3445.   Result := Left + Width;
  3446. end;
  3447.  
  3448. procedure THeaderSection.SetAlignment(Value: TAlignment);
  3449. begin
  3450.   if FAlignment <> Value then
  3451.   begin
  3452.     FAlignment := Value;
  3453.     Changed(False);
  3454.   end;
  3455. end;
  3456.  
  3457. procedure THeaderSection.SetMaxWidth(Value: Integer);
  3458. begin
  3459.   if Value < FMinWidth then Value := FMinWidth;
  3460.   if Value > 10000 then Value := 10000;
  3461.   FMaxWidth := Value;
  3462.   SetWidth(FWidth);
  3463. end;
  3464.  
  3465. procedure THeaderSection.SetMinWidth(Value: Integer);
  3466. begin
  3467.   if Value < 0 then Value := 0;
  3468.   if Value > FMaxWidth then Value := FMaxWidth;
  3469.   FMinWidth := Value;
  3470.   SetWidth(FWidth);
  3471. end;
  3472.  
  3473. procedure THeaderSection.SetStyle(Value: THeaderSectionStyle);
  3474. begin
  3475.   if FStyle <> Value then
  3476.   begin
  3477.     FStyle := Value;
  3478.     Changed(False);
  3479.   end;
  3480. end;
  3481.  
  3482. procedure THeaderSection.SetText(const Value: string);
  3483. begin
  3484.   if FText <> Value then
  3485.   begin
  3486.     FText := Value;
  3487.     Changed(False);
  3488.   end;
  3489. end;
  3490.  
  3491. procedure THeaderSection.SetWidth(Value: Integer);
  3492. begin
  3493.   if Value < FMinWidth then Value := FMinWidth;
  3494.   if Value > FMaxWidth then Value := FMaxWidth;
  3495.   if FWidth <> Value then
  3496.   begin
  3497.     FWidth := Value;
  3498.     Changed(Index < Collection.Count - 1);
  3499.   end;
  3500. end;
  3501.  
  3502. { THeaderSections }
  3503.  
  3504. constructor THeaderSections.Create(HeaderControl: THeaderControl);
  3505. begin
  3506.   inherited Create(THeaderSection);
  3507.   FHeaderControl := HeaderControl;
  3508. end;
  3509.  
  3510. function THeaderSections.Add: THeaderSection;
  3511. begin
  3512.   Result := THeaderSection(inherited Add);
  3513. end;
  3514.  
  3515. function THeaderSections.GetItem(Index: Integer): THeaderSection;
  3516. begin
  3517.   Result := THeaderSection(inherited GetItem(Index));
  3518. end;
  3519.  
  3520. function THeaderSections.GetOwner: TPersistent;
  3521. begin
  3522.   Result := FHeaderControl;
  3523. end;
  3524.  
  3525. procedure THeaderSections.SetItem(Index: Integer; Value: THeaderSection);
  3526. begin
  3527.   inherited SetItem(Index, Value);
  3528. end;
  3529.  
  3530. procedure THeaderSections.Update(Item: TCollectionItem);
  3531. begin
  3532.   if Item <> nil then
  3533.     FHeaderControl.UpdateSection(Item.Index) else
  3534.     FHeaderControl.UpdateSections;
  3535. end;
  3536.  
  3537. { THeaderControl }
  3538.  
  3539. constructor THeaderControl.Create(AOwner: TComponent);
  3540. begin
  3541.   inherited Create(AOwner);
  3542.   ControlStyle := [];
  3543.   Align := alTop;
  3544.   Height := 17;
  3545.   FSections := THeaderSections.Create(Self);
  3546.   FCanvas := TControlCanvas.Create;
  3547.   TControlCanvas(FCanvas).Control := Self;
  3548. end;
  3549.  
  3550. destructor THeaderControl.Destroy;
  3551. begin
  3552.   FCanvas.Free;
  3553.   FSections.Free;
  3554.   inherited Destroy;
  3555. end;
  3556.  
  3557. procedure THeaderControl.CreateParams(var Params: TCreateParams);
  3558. begin
  3559.   InitCommonControl(ICC_LISTVIEW_CLASSES);
  3560.   inherited CreateParams(Params);
  3561.   CreateSubClass(Params, 'SysHeader32');
  3562.   with Params do
  3563.   begin
  3564.     Style := Style or HDS_BUTTONS;
  3565. //    Style := Style or HDS_DRAGDROP or HDS_FULLDRAG;
  3566.     if FHotTrack then Style := Style or HDS_HOTTRACK;
  3567.     WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);
  3568.   end;
  3569. end;
  3570.  
  3571. procedure THeaderControl.CreateWnd;
  3572. begin
  3573.   inherited CreateWnd;
  3574.   UpdateSections;
  3575. end;
  3576.  
  3577. procedure THeaderControl.DrawSection(Section: THeaderSection;
  3578.   const Rect: TRect; Pressed: Boolean);
  3579. begin
  3580.   if Assigned(FOnDrawSection) then
  3581.     FOnDrawSection(Self, Section, Rect, Pressed) else
  3582.     FCanvas.FillRect(Rect);
  3583. end;
  3584.  
  3585. procedure THeaderControl.Resize;
  3586. begin
  3587.   if Assigned(FOnResize) then FOnResize(Self);
  3588. end;
  3589.  
  3590. procedure THeaderControl.SectionClick(Section: THeaderSection);
  3591. begin
  3592.   if Assigned(FOnSectionClick) then FOnSectionClick(Self, Section);
  3593. end;
  3594.  
  3595. procedure THeaderControl.SectionResize(Section: THeaderSection);
  3596. begin
  3597.   if Assigned(FOnSectionResize) then FOnSectionResize(Self, Section);
  3598. end;
  3599.  
  3600. procedure THeaderControl.SectionTrack(Section: THeaderSection;
  3601.   Width: Integer; State: TSectionTrackState);
  3602. begin
  3603.   if Assigned(FOnSectionTrack) then FOnSectionTrack(Self, Section, Width, State);
  3604. end;
  3605.  
  3606. procedure THeaderControl.SetHotTrack(Value: Boolean);
  3607. begin
  3608.   if FHotTrack <> Value then
  3609.   begin
  3610.     FHotTrack := Value;
  3611.     RecreateWnd;
  3612.   end;
  3613. end;
  3614.  
  3615. procedure THeaderControl.SetSections(Value: THeaderSections);
  3616. begin
  3617.   FSections.Assign(Value);
  3618. end;
  3619.  
  3620. procedure THeaderControl.UpdateItem(Message, Index: Integer);
  3621. var
  3622.   Item: THDItem;
  3623. begin
  3624.   with Sections[Index] do
  3625.   begin
  3626.     FillChar(Item, SizeOf(Item), 0);
  3627.     Item.mask := HDI_WIDTH or HDI_TEXT or HDI_FORMAT;
  3628.     Item.cxy := Width;
  3629.     Item.pszText := PChar(Text);
  3630.     Item.cchTextMax := Length(Text);
  3631.     case Alignment of
  3632.       taLeftJustify: Item.fmt := HDF_LEFT;
  3633.       taRightJustify: Item.fmt := HDF_RIGHT;
  3634.     else
  3635.       Item.fmt := HDF_CENTER;
  3636.     end;
  3637.     if Style = hsOwnerDraw then
  3638.       Item.fmt := Item.fmt or HDF_OWNERDRAW else
  3639.       Item.fmt := Item.fmt or HDF_STRING;
  3640.     SendMessage(Handle, Message, Index, Integer(@Item));
  3641.   end;
  3642. end;
  3643.  
  3644. procedure THeaderControl.UpdateSection(Index: Integer);
  3645. begin
  3646.   if HandleAllocated then UpdateItem(HDM_SETITEM, Index);
  3647. end;
  3648.  
  3649. procedure THeaderControl.UpdateSections;
  3650. var
  3651.   I: Integer;
  3652. begin
  3653.   if HandleAllocated then
  3654.   begin
  3655.     for I := 0 to SendMessage(Handle, HDM_GETITEMCOUNT, 0, 0) - 1 do
  3656.       SendMessage(Handle, HDM_DELETEITEM, 0, 0);
  3657.     for I := 0 to Sections.Count - 1 do UpdateItem(HDM_INSERTITEM, I);
  3658.   end;
  3659. end;
  3660.  
  3661. procedure THeaderControl.CNDrawItem(var Message: TWMDrawItem);
  3662. var
  3663.   SaveIndex: Integer;
  3664. begin
  3665.   with Message.DrawItemStruct^ do
  3666.   begin
  3667.     SaveIndex := SaveDC(hDC);
  3668.     FCanvas.Handle := hDC;
  3669.     FCanvas.Font := Font;
  3670.     FCanvas.Brush.Color := clBtnFace;
  3671.     FCanvas.Brush.Style := bsSolid;
  3672.     DrawSection(Sections[itemID], rcItem, itemState and ODS_SELECTED <> 0);
  3673.     FCanvas.Handle := 0;
  3674.     RestoreDC(hDC, SaveIndex);
  3675.   end;
  3676.   Message.Result := 1;
  3677. end;
  3678.  
  3679. procedure THeaderControl.CNNotify(var Message: TWMNotify);
  3680. var
  3681.   Section: THeaderSection;
  3682.   TrackState: TSectionTrackState;
  3683. begin
  3684.   with PHDNotify(Message.NMHdr)^ do
  3685.     case Hdr.code of
  3686.       HDN_ITEMCLICK:
  3687.         SectionClick(Sections[Item]);
  3688.       HDN_ITEMCHANGED:
  3689.         if PItem^.mask and HDI_WIDTH <> 0 then
  3690.         begin
  3691.           Section := Sections[Item];
  3692.           if Section.FWidth <> PItem^.cxy then
  3693.           begin
  3694.             Section.FWidth := PItem^.cxy;
  3695.             SectionResize(Section);
  3696.           end;
  3697.         end;
  3698.       HDN_BEGINTRACK, HDN_TRACK, HDN_ENDTRACK:
  3699.         begin
  3700.           Section := Sections[Item];
  3701.           case Hdr.code of
  3702.             HDN_BEGINTRACK: TrackState := tsTrackBegin;
  3703.             HDN_ENDTRACK: TrackState := tsTrackEnd;
  3704.           else
  3705.             TrackState := tsTrackMove;
  3706.           end;
  3707.           with PItem^ do
  3708.           begin
  3709.             if cxy < Section.FMinWidth then cxy := Section.FMinWidth;
  3710.             if cxy > Section.FMaxWidth then cxy := Section.FMaxWidth;
  3711.             SectionTrack(Sections[Item], cxy, TrackState);
  3712.           end;
  3713.         end;
  3714.     end;
  3715. end;
  3716.  
  3717. procedure THeaderControl.WMLButtonDown(var Message: TWMLButtonDown);
  3718. var
  3719.   Index: Integer;
  3720.   Info: THDHitTestInfo;
  3721. begin
  3722.   Info.Point.X := Message.Pos.X;
  3723.   Info.Point.Y := Message.Pos.Y;
  3724.   Index := SendMessage(Handle, HDM_HITTEST, 0, Integer(@Info));
  3725.   if (Index < 0) or (Info.Flags and HHT_ONHEADER = 0) or
  3726.     Sections[Index].AllowClick then inherited;
  3727. end;
  3728.  
  3729. procedure THeaderControl.WMSize(var Message: TWMSize);
  3730. begin
  3731.   inherited;
  3732.   if not (csLoading in ComponentState) then Resize;
  3733. end;
  3734.  
  3735. procedure THeaderControl.WMWindowPosChanged(var Message: TWMWindowPosChanged);
  3736. begin
  3737.   inherited;
  3738.   Invalidate;
  3739. end;
  3740.  
  3741. { TTreeNode }
  3742.  
  3743. function DefaultTreeViewSort(Node1, Node2: TTreeNode; lParam: Integer): Integer; stdcall;
  3744. begin
  3745.   with Node1 do
  3746.     if Assigned(TreeView.OnCompare) then
  3747.       TreeView.OnCompare(TreeView, Node1, Node2, lParam, Result)
  3748.     else Result := lstrcmp(PChar(Node1.Text), PChar(Node2.Text));
  3749. end;
  3750.  
  3751. procedure TreeViewError(const Msg: string);
  3752. begin
  3753.   raise ETreeViewError.Create(Msg);
  3754. end;
  3755.  
  3756. procedure TreeViewErrorFmt(const Msg: string; Format: array of const);
  3757. begin
  3758.   raise ETreeViewError.CreateFmt(Msg, Format);
  3759. end;
  3760.  
  3761. constructor TTreeNode.Create(AOwner: TTreeNodes);
  3762. begin
  3763.   inherited Create;
  3764.   FOverlayIndex := -1;
  3765.   FStateIndex := -1;
  3766.   FOwner := AOwner;
  3767. end;
  3768.  
  3769. destructor TTreeNode.Destroy;
  3770. var
  3771.   Node: TTreeNode;
  3772.   CheckValue: Integer;
  3773. begin
  3774.   FDeleting := True;
  3775.   if Owner.Owner.FLastDropTarget = Self then
  3776.     Owner.Owner.FLastDropTarget := nil;
  3777.   Node := Parent;
  3778.   if (Node <> nil) and (not Node.Deleting) then
  3779.   begin
  3780.     if Node.IndexOf(Self) <> -1 then CheckValue := 1
  3781.     else CheckValue := 0;
  3782.     if Node.CompareCount(CheckValue) then
  3783.     begin
  3784.       Expanded := False;
  3785.       Node.HasChildren := False;
  3786.     end;
  3787.   end;
  3788.   if ItemId <> nil then TreeView_DeleteItem(Handle, ItemId);
  3789.   Data := nil;
  3790.   inherited Destroy;
  3791. end;
  3792.  
  3793. function TTreeNode.GetHandle: HWND;
  3794. begin
  3795.   Result := TreeView.Handle;
  3796. end;
  3797.  
  3798. function TTreeNode.GetTreeView: TCustomTreeView;
  3799. begin
  3800.   Result := Owner.Owner;
  3801. end;
  3802.  
  3803. function TTreeNode.HasAsParent(Value: TTreeNode): Boolean;
  3804. begin
  3805.   if Value <> Nil then
  3806.   begin
  3807.     if Parent = Nil then Result := False
  3808.     else if Parent = Value then Result := True
  3809.     else Result := Parent.HasAsParent(Value);
  3810.   end
  3811.   else Result := True;
  3812. end;
  3813.  
  3814. procedure TTreeNode.SetText(const S: string);
  3815. var
  3816.   Item: TTVItem;
  3817. begin
  3818.   FText := S;
  3819.   with Item do
  3820.   begin
  3821.     mask := TVIF_TEXT;
  3822.     hItem := ItemId;
  3823.     pszText := LPSTR_TEXTCALLBACK;
  3824.   end;
  3825.   TreeView_SetItem(Handle, Item);
  3826.   if (TreeView.SortType in [stText, stBoth]) and FInTree then
  3827.   begin
  3828.     if (Parent <> nil) then Parent.AlphaSort
  3829.     else TreeView.AlphaSort;
  3830.   end;
  3831. end;
  3832.  
  3833. procedure TTreeNode.SetData(Value: Pointer);
  3834. begin
  3835.   FData := Value;
  3836.   if (TreeView.SortType in [stData, stBoth]) and Assigned(TreeView.OnCompare)
  3837.     and (not Deleting) and FInTree then
  3838.   begin
  3839.     if Parent <> nil then Parent.AlphaSort
  3840.     else TreeView.AlphaSort;
  3841.   end;
  3842. end;
  3843.  
  3844. function TTreeNode.GetState(NodeState: TNodeState): Boolean;
  3845. var
  3846.   Item: TTVItem;
  3847. begin
  3848.   Result := False;
  3849.   with Item do
  3850.   begin
  3851.     mask := TVIF_STATE;
  3852.     hItem := ItemId;
  3853.     if TreeView_GetItem(Handle, Item) then
  3854.       case NodeState of
  3855.         nsCut: Result := (state and TVIS_CUT) <> 0;
  3856.         nsFocused: Result := (state and TVIS_FOCUSED) <> 0;
  3857.         nsSelected: Result := (state and TVIS_SELECTED) <> 0;
  3858.         nsExpanded: Result := (state and TVIS_EXPANDED) <> 0;
  3859.         nsDropHilited: Result := (state and TVIS_DROPHILITED) <> 0;
  3860.       end;
  3861.   end;
  3862. end;
  3863.  
  3864. procedure TTreeNode.SetImageIndex(Value: Integer);
  3865. var
  3866.   Item: TTVItem;
  3867. begin
  3868.   FImageIndex := Value;
  3869.   with Item do
  3870.   begin
  3871.     mask := TVIF_IMAGE or TVIF_HANDLE;
  3872.     hItem := ItemId;
  3873.     iImage := FImageIndex;
  3874.   end;
  3875.   TreeView_SetItem(Handle, Item);
  3876. end;
  3877.  
  3878. procedure TTreeNode.SetSelectedIndex(Value: Integer);
  3879. var
  3880.   Item: TTVItem;
  3881. begin
  3882.   FSelectedIndex := Value;
  3883.   with Item do
  3884.   begin
  3885.     mask := TVIF_SELECTEDIMAGE or TVIF_HANDLE;
  3886.     hItem := ItemId;
  3887.     iSelectedImage := I_IMAGECALLBACK;
  3888.   end;
  3889.   TreeView_SetItem(Handle, Item);
  3890. end;
  3891.  
  3892. procedure TTreeNode.SetOverlayIndex(Value: Integer);
  3893. var
  3894.   Item: TTVItem;
  3895. begin
  3896.   FOverlayIndex := Value;
  3897.   with Item do
  3898.   begin
  3899.     mask := TVIF_STATE or TVIF_HANDLE;
  3900.     stateMask := TVIS_OVERLAYMASK;
  3901.     hItem := ItemId;
  3902.     state := IndexToOverlayMask(OverlayIndex + 1);
  3903.   end;
  3904.   TreeView_SetItem(Handle, Item);
  3905. end;
  3906.  
  3907. procedure TTreeNode.SetStateIndex(Value: Integer);
  3908. var
  3909.   Item: TTVItem;
  3910. begin
  3911.   FStateIndex := Value;
  3912.   if Value >= 0 then Dec(Value);
  3913.   with Item do
  3914.   begin
  3915.     mask := TVIF_STATE or TVIF_HANDLE;
  3916.     stateMask := TVIS_STATEIMAGEMASK;
  3917.     hItem := ItemId;
  3918.     state := IndexToStateImageMask(Value + 1);
  3919.   end;
  3920.   TreeView_SetItem(Handle, Item);
  3921. end;
  3922.  
  3923. function TTreeNode.CompareCount(CompareMe: Integer): Boolean;
  3924. var
  3925.   Count: integer;
  3926.   Node: TTreeNode;
  3927. Begin
  3928.   Count := 0;
  3929.   Result := False;
  3930.   Node := GetFirstChild;
  3931.   while Node <> nil do
  3932.   begin
  3933.     Inc(Count);
  3934.     Node := Node.GetNextChild(Node);
  3935.     if Count > CompareMe then Exit;
  3936.   end;
  3937.   if Count = CompareMe then Result := True;
  3938. end;
  3939.  
  3940. function TTreeNode.DoCanExpand(Expand: Boolean): Boolean;
  3941. begin
  3942.   Result := False;
  3943.   if HasChildren then
  3944.   begin
  3945.     if Expand then Result := TreeView.CanExpand(Self)
  3946.     else Result := TreeView.CanCollapse(Self);
  3947.   end;
  3948. end;
  3949.  
  3950. procedure TTreeNode.DoExpand(Expand: Boolean);
  3951. begin
  3952.   if HasChildren then
  3953.   begin
  3954.     if Expand then TreeView.Expand(Self)
  3955.     else TreeView.Collapse(Self);
  3956.   end;
  3957. end;
  3958.  
  3959. procedure TTreeNode.ExpandItem(Expand: Boolean; Recurse: Boolean);
  3960. var
  3961.   Flag: Integer;
  3962.   Node: TTreeNode;
  3963. begin
  3964.   if Recurse then
  3965.   begin
  3966.     Node := Self;
  3967.     repeat
  3968.       Node.ExpandItem(Expand, False);
  3969.       Node := Node.GetNext;
  3970.     until (Node = nil) or (not Node.HasAsParent(Self));
  3971.   end
  3972.   else begin
  3973.     TreeView.FManualNotify := True;
  3974.     try
  3975.       Flag := 0;
  3976.       if Expand then
  3977.       begin
  3978.         if DoCanExpand(True) then
  3979.         begin
  3980.           Flag := TVE_EXPAND;
  3981.           DoExpand(True);
  3982.         end;
  3983.       end
  3984.       else begin
  3985.         if DoCanExpand(False) then
  3986.         begin
  3987.           Flag := TVE_COLLAPSE;
  3988.           DoExpand(False);
  3989.         end;
  3990.       end;
  3991.       if Flag <> 0 then TreeView_Expand(Handle, ItemId, Flag);
  3992.     finally
  3993.       TreeView.FManualNotify := False;
  3994.     end;
  3995.   end;
  3996. end;
  3997.  
  3998. procedure TTreeNode.Expand(Recurse: Boolean);
  3999. begin
  4000.   ExpandItem(True, Recurse);
  4001. end;
  4002.  
  4003. procedure TTreeNode.Collapse(Recurse: Boolean);
  4004. begin
  4005.   ExpandItem(False, Recurse);
  4006. end;
  4007.  
  4008. function TTreeNode.GetExpanded: Boolean;
  4009. begin
  4010.   Result := GetState(nsExpanded);
  4011. end;
  4012.  
  4013. procedure TTreeNode.SetExpanded(Value: Boolean);
  4014. begin
  4015.   if Value then Expand(False)
  4016.   else Collapse(False);
  4017. end;
  4018.  
  4019. function TTreeNode.GetSelected: Boolean;
  4020. begin
  4021.   Result := GetState(nsSelected);
  4022. end;
  4023.  
  4024. procedure TTreeNode.SetSelected(Value: Boolean);
  4025. begin
  4026.   if Value then TreeView_SelectItem(Handle, ItemId)
  4027.   else if Selected then TreeView_SelectItem(Handle, nil);
  4028. end;
  4029.  
  4030. function TTreeNode.GetCut: Boolean;
  4031. begin
  4032.   Result := GetState(nsCut);
  4033. end;
  4034.  
  4035. procedure TTreeNode.SetCut(Value: Boolean);
  4036. var
  4037.   Item: TTVItem;
  4038.   Template: Integer;
  4039. begin
  4040.   if Value then Template := -1
  4041.   else Template := 0;
  4042.   with Item do
  4043.   begin
  4044.     mask := TVIF_STATE;
  4045.     hItem := ItemId;
  4046.     stateMask := TVIS_CUT;
  4047.     state := stateMask and Template;
  4048.   end;
  4049.   TreeView_SetItem(Handle, Item);
  4050. end;
  4051.  
  4052. function TTreeNode.GetDropTarget: Boolean;
  4053. begin
  4054.   Result := GetState(nsDropHilited);
  4055. end;
  4056.  
  4057. procedure TTreeNode.SetDropTarget(Value: Boolean);
  4058. begin
  4059.   if Value then TreeView_SelectDropTarget(Handle, ItemId)
  4060.   else if DropTarget then TreeView_SelectDropTarget(Handle, nil);
  4061. end;
  4062.  
  4063. function TTreeNode.GetChildren: Boolean;
  4064. var
  4065.   Item: TTVItem;
  4066. begin
  4067.   Item.mask := TVIF_CHILDREN;
  4068.   Item.hItem := ItemId;
  4069.   if TreeView_GetItem(Handle, Item) then Result := Item.cChildren > 0
  4070.   else Result := False;
  4071. end;
  4072.  
  4073. procedure TTreeNode.SetFocused(Value: Boolean);
  4074. var
  4075.   Item: TTVItem;
  4076.   Template: Integer;
  4077. begin
  4078.   if Value then Template := -1
  4079.   else Template := 0;
  4080.   with Item do
  4081.   begin
  4082.     mask := TVIF_STATE;
  4083.     hItem := ItemId;
  4084.     stateMask := TVIS_FOCUSED;
  4085.     state := stateMask and Template;
  4086.   end;
  4087.   TreeView_SetItem(Handle, Item);
  4088. end;
  4089.  
  4090. function TTreeNode.GetFocused: Boolean;
  4091. begin
  4092.   Result := GetState(nsFocused);
  4093. end;
  4094.  
  4095. procedure TTreeNode.SetChildren(Value: Boolean);
  4096. var
  4097.   Item: TTVItem;
  4098. begin
  4099.   with Item do
  4100.   begin
  4101.     mask := TVIF_CHILDREN;
  4102.     hItem := ItemId;
  4103.     cChildren := Ord(Value);
  4104.   end;
  4105.   TreeView_SetItem(Handle, Item);
  4106. end;
  4107.  
  4108. function TTreeNode.GetParent: TTreeNode;
  4109. begin
  4110.   with FOwner do
  4111.     Result := GetNode(TreeView_GetParent(Handle, ItemId));
  4112. end;
  4113.  
  4114. function TTreeNode.GetNextSibling: TTreeNode;
  4115. begin
  4116.   with FOwner do
  4117.     Result := GetNode(TreeView_GetNextSibling(Handle, ItemId));
  4118. end;
  4119.  
  4120. function TTreeNode.GetPrevSibling: TTreeNode;
  4121. begin
  4122.   with FOwner do
  4123.     Result := GetNode(TreeView_GetPrevSibling(Handle, ItemId));
  4124. end;
  4125.  
  4126. function TTreeNode.GetNextVisible: TTreeNode;
  4127. begin
  4128.   if IsVisible then
  4129.     with FOwner do
  4130.       Result := GetNode(TreeView_GetNextVisible(Handle, ItemId))
  4131.   else Result := nil;
  4132. end;
  4133.  
  4134. function TTreeNode.GetPrevVisible: TTreeNode;
  4135. begin
  4136.   with FOwner do
  4137.     Result := GetNode(TreeView_GetPrevVisible(Handle, ItemId));
  4138. end;
  4139.  
  4140. function TTreeNode.GetNextChild(Value: TTreeNode): TTreeNode;
  4141. begin
  4142.   if Value <> nil then Result := Value.GetNextSibling
  4143.   else Result := nil;
  4144. end;
  4145.  
  4146. function TTreeNode.GetPrevChild(Value: TTreeNode): TTreeNode;
  4147. begin
  4148.   if Value <> nil then Result := Value.GetPrevSibling
  4149.   else Result := nil;
  4150. end;
  4151.  
  4152. function TTreeNode.GetFirstChild: TTreeNode;
  4153. begin
  4154.   with FOwner do
  4155.     Result := GetNode(TreeView_GetChild(Handle, ItemId));
  4156. end;
  4157.  
  4158. function TTreeNode.GetLastChild: TTreeNode;
  4159. var
  4160.   Node: TTreeNode;
  4161. begin
  4162.   Result := GetFirstChild;
  4163.   if Result <> nil then
  4164.   begin
  4165.     Node := Result;
  4166.     repeat
  4167.       Result := Node;
  4168.       Node := Result.GetNextSibling;
  4169.     until Node = nil;
  4170.   end;
  4171. end;
  4172.  
  4173. function TTreeNode.GetNext: TTreeNode;
  4174. var
  4175.   NodeID, ParentID: HTreeItem;
  4176.   Handle: HWND;
  4177. begin
  4178.   Handle := FOwner.Handle;
  4179.   NodeID := TreeView_GetChild(Handle, ItemId);
  4180.   if NodeID = nil then NodeID := TreeView_GetNextSibling(Handle, ItemId);
  4181.   ParentID := ItemId;
  4182.   while (NodeID = nil) and (ParentID <> nil) do
  4183.   begin
  4184.     ParentID := TreeView_GetParent(Handle, ParentID);
  4185.     NodeID := TreeView_GetNextSibling(Handle, ParentID);
  4186.   end;
  4187.   Result := FOwner.GetNode(NodeID);
  4188. end;
  4189.  
  4190. function TTreeNode.GetPrev: TTreeNode;
  4191. var
  4192.   Node: TTreeNode;
  4193. begin
  4194.   Result := GetPrevSibling;
  4195.   if Result <> nil then
  4196.   begin
  4197.     Node := Result;
  4198.     repeat
  4199.       Result := Node;
  4200.       Node := Result.GetLastChild;
  4201.     until Node = nil;
  4202.   end else
  4203.     Result := Parent;
  4204. end;
  4205.  
  4206. function TTreeNode.GetAbsoluteIndex: Integer;
  4207. var
  4208.   Node: TTreeNode;
  4209. begin
  4210.   Result := -1;
  4211.   Node := Self;
  4212.   while Node <> nil do
  4213.   begin
  4214.     Inc(Result);
  4215.     Node := Node.GetPrev;
  4216.   end;
  4217. end;
  4218.  
  4219. function TTreeNode.GetIndex: Integer;
  4220. var
  4221.   Node: TTreeNode;
  4222. begin
  4223.   Result := -1;
  4224.   Node := Self;
  4225.   while Node <> nil do
  4226.   begin
  4227.     Inc(Result);
  4228.     Node := Node.GetPrevSibling;
  4229.   end;
  4230. end;
  4231.  
  4232. function TTreeNode.GetItem(Index: Integer): TTreeNode;
  4233. begin
  4234.   Result := GetFirstChild;
  4235.   while (Result <> nil) and (Index > 0) do
  4236.   begin
  4237.     Result := GetNextChild(Result);
  4238.     Dec(Index);
  4239.   end;
  4240.   if Result = nil then TreeViewError(SListIndexError);
  4241. end;
  4242.  
  4243. procedure TTreeNode.SetItem(Index: Integer; Value: TTreeNode);
  4244. begin
  4245.   item[Index].Assign(Value);
  4246. end;
  4247.  
  4248. function TTreeNode.IndexOf(Value: TTreeNode): Integer;
  4249. var
  4250.   Node: TTreeNode;
  4251. begin
  4252.   Result := -1;
  4253.   Node := GetFirstChild;
  4254.   while (Node <> nil) do
  4255.   begin
  4256.     Inc(Result);
  4257.     if Node = Value then Break;
  4258.     Node := GetNextChild(Node);
  4259.   end;
  4260.   if Node = nil then Result := -1;
  4261. end;
  4262.  
  4263. function TTreeNode.GetCount: Integer;
  4264. var
  4265.   Node: TTreeNode;
  4266. begin
  4267.   Result := 0;
  4268.   Node := GetFirstChild;
  4269.   while Node <> nil do
  4270.   begin
  4271.     Inc(Result);
  4272.     Node := Node.GetNextChild(Node);
  4273.   end;
  4274. end;
  4275.  
  4276. procedure TTreeNode.EndEdit(Cancel: Boolean);
  4277. begin
  4278.   TreeView_EndEditLabelNow(Handle, Cancel);
  4279. end;
  4280.  
  4281. procedure TTreeNode.InternalMove(ParentNode, Node: TTreeNode;
  4282.   HItem: HTreeItem; AddMode: TAddMode);
  4283. var
  4284.   I: Integer;
  4285.   NodeId: HTreeItem;
  4286.   TreeViewItem: TTVItem;
  4287.   Children: Boolean;
  4288.   IsSelected: Boolean;
  4289. begin
  4290.   if (AddMode = taInsert) and (Node <> nil) then
  4291.     NodeId := Node.ItemId else
  4292.     NodeId := nil;
  4293.   Children := HasChildren;
  4294.   IsSelected := Selected;
  4295.   if (Parent <> nil) and (Parent.CompareCount(1)) then
  4296.   begin
  4297.     Parent.Expanded := False;
  4298.     Parent.HasChildren := False;
  4299.   end;
  4300.   with TreeViewItem do
  4301.   begin
  4302.     mask := TVIF_PARAM;
  4303.     hItem := ItemId;
  4304.     lParam := 0;
  4305.   end;
  4306.   TreeView_SetItem(Handle, TreeViewItem);
  4307.   with Owner do
  4308.     HItem := AddItem(HItem, NodeId, CreateItem(Self), AddMode);
  4309.   if HItem = nil then
  4310.     raise EOutOfResources.Create(sInsertError);
  4311.   for I := Count - 1 downto 0 do
  4312.     Item[I].InternalMove(Self, nil, HItem, taAddFirst);
  4313.   TreeView_DeleteItem(Handle, ItemId);
  4314.   FItemId := HItem;
  4315.   Assign(Self);
  4316.   HasChildren := Children;
  4317.   Selected := IsSelected;
  4318. end;
  4319.  
  4320. procedure TTreeNode.MoveTo(Destination: TTreeNode; Mode: TNodeAttachMode);
  4321. var
  4322.   AddMode: TAddMode;
  4323.   Node: TTreeNode;
  4324.   HItem: HTreeItem;
  4325.   OldOnChanging: TTVChangingEvent;
  4326.   OldOnChange: TTVChangedEvent;
  4327. begin
  4328.   OldOnChanging := TreeView.OnChanging;
  4329.   OldOnChange := TreeView.OnChange;
  4330.   TreeView.OnChanging := nil;
  4331.   TreeView.OnChange := nil;
  4332.   try
  4333.     if (Destination = nil) or not Destination.HasAsParent(Self) then
  4334.     begin
  4335.       AddMode := taAdd;
  4336.       if (Destination <> nil) and not (Mode in [naAddChild, naAddChildFirst]) then
  4337.         Node := Destination.Parent else
  4338.         Node := Destination;
  4339.       case Mode of
  4340.         naAdd,
  4341.         naAddChild: AddMode := taAdd;
  4342.         naAddFirst,
  4343.         naAddChildFirst: AddMode := taAddFirst;
  4344.         naInsert:
  4345.           begin
  4346.             Destination := Destination.GetPrevSibling;
  4347.             if Destination = nil then AddMode := taAddFirst
  4348.             else AddMode := taInsert;
  4349.           end;
  4350.       end;
  4351.       if Node <> nil then
  4352.         HItem := Node.ItemId else
  4353.         HItem := nil;
  4354.       InternalMove(Node, Destination, HItem, AddMode);
  4355.       Node := Parent;
  4356.       if Node <> nil then
  4357.       begin
  4358.         Node.HasChildren := True;
  4359. //        Node.ExpandItem(True, False);
  4360.         Node.Expanded := True;
  4361.       end;
  4362.     end;
  4363.   finally
  4364.     TreeView.OnChanging := OldOnChanging;
  4365.     TreeView.OnChange := OldOnChange;
  4366.   end;
  4367. end;
  4368.  
  4369. procedure TTreeNode.MakeVisible;
  4370. begin
  4371.   TreeView_EnsureVisible(Handle, ItemId);
  4372. end;
  4373.  
  4374. function TTreeNode.GetLevel: Integer;
  4375. var
  4376.   Node: TTreeNode;
  4377. begin
  4378.   Result := 0;
  4379.   Node := Parent;
  4380.   while Node <> nil do
  4381.   begin
  4382.     Inc(Result);
  4383.     Node := Node.Parent;
  4384.   end;
  4385. end;
  4386.  
  4387. function TTreeNode.IsNodeVisible: Boolean;
  4388. var
  4389.   Rect: TRect;
  4390. begin
  4391.   Result := TreeView_GetItemRect(Handle, ItemId, Rect, True);
  4392. end;
  4393.  
  4394. function TTreeNode.EditText: Boolean;
  4395. begin
  4396.   Result := TreeView_EditLabel(Handle, ItemId) <> 0;
  4397. end;
  4398.  
  4399. function TTreeNode.DisplayRect(TextOnly: Boolean): TRect;
  4400. begin
  4401.   FillChar(Result, SizeOf(Result), 0);
  4402.   TreeView_GetItemRect(Handle, ItemId, Result, TextOnly);
  4403. end;
  4404.  
  4405. function TTreeNode.AlphaSort: Boolean;
  4406. begin
  4407.   Result := CustomSort(nil, 0);
  4408. end;
  4409.  
  4410. function TTreeNode.CustomSort(SortProc: TTVCompare; Data: Longint): Boolean;
  4411. var
  4412.   SortCB: TTVSortCB;
  4413. begin
  4414.   with SortCB do
  4415.   begin
  4416.     if not Assigned(SortProc) then lpfnCompare := @DefaultTreeViewSort
  4417.     else lpfnCompare := SortProc;
  4418.     hParent := ItemId;
  4419.     lParam := Data;
  4420.   end;
  4421.   Result := TreeView_SortChildrenCB(Handle, SortCB, 0);
  4422. end;
  4423.  
  4424. procedure TTreeNode.Delete;
  4425. begin
  4426.   if not Deleting then Free;
  4427. end;
  4428.  
  4429. procedure TTreeNode.DeleteChildren;
  4430. begin
  4431.   TreeView_Expand(TreeView.Handle, ItemID, TVE_COLLAPSE or TVE_COLLAPSERESET);
  4432.   HasChildren := False;
  4433. end;
  4434.  
  4435. procedure TTreeNode.Assign(Source: TPersistent);
  4436. var
  4437.   Node: TTreeNode;
  4438. begin
  4439.   if Source is TTreeNode then
  4440.   begin
  4441.     Node := TTreeNode(Source);
  4442.     Text := Node.Text;
  4443.     Data := Node.Data;
  4444.     ImageIndex := Node.ImageIndex;
  4445.     SelectedIndex := Node.SelectedIndex;
  4446.     StateIndex := Node.StateIndex;
  4447.     OverlayIndex := Node.OverlayIndex;
  4448.     Focused := Node.Focused;
  4449.     DropTarget := Node.DropTarget;
  4450.     Cut := Node.Cut;
  4451.     HasChildren := Node.HasChildren;
  4452.   end
  4453.   else inherited Assign(Source);
  4454. end;
  4455.  
  4456. function TTreeNode.IsEqual(Node: TTreeNode): Boolean;
  4457. begin
  4458.   Result := (Text = Node.Text) and (Data = Node.Data);
  4459. end;
  4460.  
  4461. procedure TTreeNode.ReadData(Stream: TStream; Info: PNodeInfo);
  4462. var
  4463.   I, Size, ItemCount: Integer;
  4464. begin
  4465.   Stream.ReadBuffer(Size, SizeOf(Size));
  4466.   Stream.ReadBuffer(Info^, Size);
  4467.   Text := Info^.Text;
  4468.   ImageIndex := Info^.ImageIndex;
  4469.   SelectedIndex := Info^.SelectedIndex;
  4470.   StateIndex := Info^.StateIndex;
  4471.   OverlayIndex := Info^.OverlayIndex;
  4472.   Data := Info^.Data;
  4473.   ItemCount := Info^.Count;
  4474.   for I := 0 to ItemCount - 1 do
  4475.     with Owner.AddChild(Self, '') do ReadData(Stream, Info);
  4476. end;
  4477.  
  4478. procedure TTreeNode.WriteData(Stream: TStream; Info: PNodeInfo);
  4479. var
  4480.   I, Size, L, ItemCount: Integer;
  4481. begin
  4482.   L := Length(Text);
  4483.   if L > 255 then L := 255;
  4484.   Size := SizeOf(TNodeInfo) + L - 255;
  4485.   Info^.Text := Text;
  4486.   Info^.ImageIndex := ImageIndex;
  4487.   Info^.SelectedIndex := SelectedIndex;
  4488.   Info^.OverlayIndex := OverlayIndex;
  4489.   Info^.StateIndex := StateIndex;
  4490.   Info^.Data := Data;
  4491.   ItemCount := Count;
  4492.   Info^.Count := ItemCount;
  4493.   Stream.WriteBuffer(Size, SizeOf(Size));
  4494.   Stream.WriteBuffer(Info^, Size);
  4495.   for I := 0 to ItemCount - 1 do Item[I].WriteData(Stream, Info);
  4496. end;
  4497.  
  4498. { TTreeNodes }
  4499.  
  4500. constructor TTreeNodes.Create(AOwner: TCustomTreeView);
  4501. begin
  4502.   inherited Create;
  4503.   FOwner := AOwner;
  4504. end;
  4505.  
  4506. destructor TTreeNodes.Destroy;
  4507. begin
  4508.   Clear;
  4509.   inherited Destroy;
  4510. end;
  4511.  
  4512. function TTreeNodes.GetCount: Integer;
  4513. begin
  4514.   if Owner.HandleAllocated then Result := TreeView_GetCount(Handle)
  4515.   else Result := 0;
  4516. end;
  4517.  
  4518. function TTreeNodes.GetHandle: HWND;
  4519. begin
  4520.   Result := Owner.Handle;
  4521. end;
  4522.  
  4523. procedure TTreeNodes.Delete(Node: TTreeNode);
  4524. begin
  4525.   if (Node.ItemId = nil) and Assigned(Owner.FOnDeletion) then
  4526.     Owner.FOnDeletion(Self, Node);
  4527.   Node.Delete;
  4528. end;
  4529.  
  4530. procedure TTreeNodes.Clear;
  4531. begin
  4532.   if Owner.HandleAllocated then
  4533.     TreeView_DeleteAllItems(Handle);
  4534. end;
  4535.  
  4536. function TTreeNodes.AddChildFirst(Node: TTreeNode; const S: string): TTreeNode;
  4537. begin
  4538.   Result := AddChildObjectFirst(Node, S, nil);
  4539. end;
  4540.  
  4541. function TTreeNodes.AddChildObjectFirst(Node: TTreeNode; const S: string;
  4542.   Ptr: Pointer): TTreeNode;
  4543. begin
  4544.   Result := InternalAddObject(Node, S, Ptr, taAddFirst);
  4545. end;
  4546.  
  4547. function TTreeNodes.AddChild(Node: TTreeNode; const S: string): TTreeNode;
  4548. begin
  4549.   Result := AddChildObject(Node, S, nil);
  4550. end;
  4551.  
  4552. function TTreeNodes.AddChildObject(Node: TTreeNode; const S: string;
  4553.   Ptr: Pointer): TTreeNode;
  4554. begin
  4555.   Result := InternalAddObject(Node, S, Ptr, taAdd);
  4556. end;
  4557.  
  4558. function TTreeNodes.AddFirst(Node: TTreeNode; const S: string): TTreeNode;
  4559. begin
  4560.   Result := AddObjectFirst(Node, S, nil);
  4561. end;
  4562.  
  4563. function TTreeNodes.AddObjectFirst(Node: TTreeNode; const S: string;
  4564.   Ptr: Pointer): TTreeNode;
  4565. begin
  4566.   if Node <> nil then Node := Node.Parent;
  4567.   Result := InternalAddObject(Node, S, Ptr, taAddFirst);
  4568. end;
  4569.  
  4570. function TTreeNodes.Add(Node: TTreeNode; const S: string): TTreeNode;
  4571. begin
  4572.   Result := AddObject(Node, S, nil);
  4573. end;
  4574.  
  4575. procedure TTreeNodes.Repaint(Node: TTreeNode);
  4576. var
  4577.   R: TRect;
  4578. begin
  4579.   if FUpdateCount < 1 then
  4580.   begin
  4581.     while (Node <> nil) and not Node.IsVisible do Node := Node.Parent;
  4582.     if Node <> nil then
  4583.     begin
  4584.       R := Node.DisplayRect(False);
  4585.       InvalidateRect(Owner.Handle, @R, True);
  4586.     end;
  4587.   end;
  4588. end;
  4589.  
  4590. function TTreeNodes.AddObject(Node: TTreeNode; const S: string;
  4591.   Ptr: Pointer): TTreeNode;
  4592. begin
  4593.   if Node <> nil then Node := Node.Parent;
  4594.   Result := InternalAddObject(Node, S, Ptr, taAdd);
  4595. end;
  4596.  
  4597. function TTreeNodes.Insert(Node: TTreeNode; const S: string): TTreeNode;
  4598. begin
  4599.   Result := InsertObject(Node, S, nil);
  4600. end;
  4601.  
  4602. procedure TTreeNodes.AddedNode(Value: TTreeNode);
  4603. begin
  4604. //  Value := Value.Parent;
  4605.   if Value <> nil then
  4606.   begin
  4607.     Value.HasChildren := True;
  4608.     Repaint(Value);
  4609.   end;
  4610. end;
  4611.  
  4612. function TTreeNodes.InsertObject(Node: TTreeNode; const S: string;
  4613.   Ptr: Pointer): TTreeNode;
  4614. var
  4615.   Item, ItemId: HTreeItem;
  4616.   Parent: TTreeNode;
  4617.   AddMode: TAddMode;
  4618. begin
  4619.   Result := Owner.CreateNode;
  4620.   try
  4621.     Item := nil;
  4622.     ItemId := nil;
  4623.     Parent := nil;
  4624.     AddMode := taInsert;
  4625.     if Node <> nil then
  4626.     begin
  4627.       Parent := Node.Parent;
  4628.       if Parent <> nil then Item := Parent.ItemId;
  4629.       Node := Node.GetPrevSibling;
  4630.       if Node <> nil then ItemId := Node.ItemId
  4631.       else AddMode := taAddFirst;
  4632.     end;
  4633.     Result.Data := Ptr;
  4634.     Result.Text := S;
  4635.     Item := AddItem(Item, ItemId, CreateItem(Result), AddMode);
  4636.     if Item = nil then
  4637.       raise EOutOfResources.Create(sInsertError);
  4638.     Result.FItemId := Item;
  4639. //    AddedNode(Result);
  4640.     AddedNode(Parent);
  4641.   except
  4642.     Result.Free;
  4643.     raise;
  4644.   end;
  4645. end;
  4646.  
  4647. function TTreeNodes.InternalAddObject(Node: TTreeNode; const S: string;
  4648.   Ptr: Pointer; AddMode: TAddMode): TTreeNode;
  4649. var
  4650.   Item: HTreeItem;
  4651. begin
  4652.   Result := Owner.CreateNode;
  4653.   try
  4654.     if Node <> nil then Item := Node.ItemId
  4655.     else Item := nil;
  4656.     Result.Data := Ptr;
  4657.     Result.Text := S;
  4658.     Item := AddItem(Item, nil, CreateItem(Result), AddMode);
  4659.     if Item = nil then
  4660.       raise EOutOfResources.Create(sInsertError);
  4661.     Result.FItemId := Item;
  4662. //    AddedNode(Result);
  4663.     AddedNode(Node);
  4664.   except
  4665.     Result.Free;
  4666.     raise;
  4667.   end;
  4668. end;
  4669.  
  4670. function TTreeNodes.CreateItem(Node: TTreeNode): TTVItem;
  4671. begin
  4672.   Node.FInTree := True;
  4673.   with Result do
  4674.   begin
  4675.     mask := TVIF_TEXT or TVIF_PARAM or TVIF_IMAGE or TVIF_SELECTEDIMAGE;
  4676.     lParam := Longint(Node);
  4677.     pszText := LPSTR_TEXTCALLBACK;
  4678.     iImage := I_IMAGECALLBACK;
  4679.     iSelectedImage := I_IMAGECALLBACK;
  4680.   end;
  4681. end;
  4682.  
  4683. function TTreeNodes.AddItem(Parent, Target: HTreeItem;
  4684.   const Item: TTVItem; AddMode: TAddMode): HTreeItem;
  4685. var
  4686.   InsertStruct: TTVInsertStruct;
  4687. begin
  4688.   with InsertStruct do
  4689.   begin
  4690.     hParent := Parent;
  4691.     case AddMode of
  4692.       taAddFirst:
  4693.         hInsertAfter := TVI_FIRST;
  4694.       taAdd:
  4695.         hInsertAfter := TVI_LAST;
  4696.       taInsert:
  4697.         hInsertAfter := Target;
  4698.     end;
  4699.   end;
  4700.   InsertStruct.item := Item;
  4701.   Result := TreeView_InsertItem(Handle, InsertStruct);
  4702. end;
  4703.  
  4704. function TTreeNodes.GetFirstNode: TTreeNode;
  4705. begin
  4706.   Result := GetNode(TreeView_GetRoot(Handle));
  4707. end;
  4708.  
  4709. function TTreeNodes.GetNodeFromIndex(Index: Integer): TTreeNode;
  4710. begin
  4711.   Result := GetFirstNode;
  4712.   while (Index <> 0) and (Result <> nil) do
  4713.   begin
  4714.     Result := Result.GetNext;
  4715.     Dec(Index);
  4716.   end;
  4717.   if Result = nil then TreeViewError(sInvalidIndex);
  4718. end;
  4719.  
  4720. function TTreeNodes.GetNode(ItemId: HTreeItem): TTreeNode;
  4721. var
  4722.   Item: TTVItem;
  4723. begin
  4724.   with Item do
  4725.   begin
  4726.     hItem := ItemId;
  4727.     mask := TVIF_PARAM;
  4728.   end;
  4729.   if TreeView_GetItem(Handle, Item) then Result := TTreeNode(Item.lParam)
  4730.   else Result := nil;
  4731. end;
  4732.  
  4733. procedure TTreeNodes.SetItem(Index: Integer; Value: TTreeNode);
  4734. begin
  4735.   GetNodeFromIndex(Index).Assign(Value);
  4736. end;
  4737.  
  4738. procedure TTreeNodes.BeginUpdate;
  4739. begin
  4740.   if FUpdateCount = 0 then SetUpdateState(True);
  4741.   Inc(FUpdateCount);
  4742. end;
  4743.  
  4744. procedure TTreeNodes.SetUpdateState(Updating: Boolean);
  4745. begin
  4746.   SendMessage(Handle, WM_SETREDRAW, Ord(not Updating), 0);
  4747.   if Updating then
  4748.     with Owner do
  4749.     begin
  4750.       FSavedSort := SortType;
  4751.       SortType := stNone;
  4752.     end
  4753.   else
  4754.     with Owner do
  4755.     begin
  4756.       SortType := FSavedSort;
  4757.       Refresh;
  4758.     end;
  4759. end;
  4760.  
  4761. procedure TTreeNodes.EndUpdate;
  4762. begin
  4763.   Dec(FUpdateCount);
  4764.   if FUpdateCount = 0 then SetUpdateState(False);
  4765. end;
  4766.  
  4767. procedure TTreeNodes.Assign(Source: TPersistent);
  4768. var
  4769.   TreeNodes: TTreeNodes;
  4770.   MemStream: TMemoryStream;
  4771. begin
  4772.   if Source is TTreeNodes then
  4773.   begin
  4774.     TreeNodes := TTreeNodes(Source);
  4775.     Clear;
  4776.     MemStream := TMemoryStream.Create;
  4777.     try
  4778.       TreeNodes.WriteData(MemStream);
  4779.       MemStream.Position := 0;
  4780.       ReadData(MemStream);
  4781.     finally
  4782.       MemStream.Free;
  4783.     end;
  4784.   end
  4785.   else inherited Assign(Source);
  4786. end;
  4787.  
  4788. procedure TTreeNodes.DefineProperties(Filer: TFiler);
  4789.  
  4790.   function WriteNodes: Boolean;
  4791.   var
  4792.     I: Integer;
  4793.     Nodes: TTreeNodes;
  4794.   begin
  4795.     Nodes := TTreeNodes(Filer.Ancestor);
  4796.     Result := False;
  4797.     if (Nodes <> nil) and (Nodes.Count = Count) then
  4798.       for I := 0 to Count - 1 do
  4799.       begin
  4800.         Result := not Item[I].IsEqual(Nodes[I]);
  4801.         if Result then Exit;
  4802.       end
  4803.     else Result := Count > 0;
  4804.   end;
  4805.  
  4806. begin
  4807.   inherited DefineProperties(Filer);
  4808.   Filer.DefineBinaryProperty('Data', ReadData, WriteData, WriteNodes);
  4809. end;
  4810.  
  4811. procedure TTreeNodes.ReadData(Stream: TStream);
  4812. var
  4813.   I, Count: Integer;
  4814.   NodeInfo: TNodeInfo;
  4815. begin
  4816.   Clear;
  4817.   Stream.ReadBuffer(Count, SizeOf(Count));
  4818.   for I := 0 to Count - 1 do
  4819.     Add(nil, '').ReadData(Stream, @NodeInfo);
  4820. end;
  4821.  
  4822. procedure TTreeNodes.WriteData(Stream: TStream);
  4823. var
  4824.   I: Integer;
  4825.   Node: TTreeNode;
  4826.   NodeInfo: TNodeInfo;
  4827. begin
  4828.   I := 0;
  4829.   Node := GetFirstNode;
  4830.   while Node <> nil do
  4831.   begin
  4832.     Inc(I);
  4833.     Node := Node.GetNextSibling;
  4834.   end;
  4835.   Stream.WriteBuffer(I, SizeOf(I));
  4836.   Node := GetFirstNode;
  4837.   while Node <> nil do
  4838.   begin
  4839.     Node.WriteData(Stream, @NodeInfo);
  4840.     Node := Node.GetNextSibling;
  4841.   end;
  4842. end;
  4843.  
  4844. type
  4845.   TTreeStrings = class(TStrings)
  4846.   private
  4847.     FOwner: TTreeNodes;
  4848.   protected
  4849.     function Get(Index: Integer): string; override;
  4850.     function GetBufStart(Buffer: PChar; var Level: Integer): PChar;
  4851.     function GetCount: Integer; override;
  4852.     function GetObject(Index: Integer): TObject; override;
  4853.     procedure PutObject(Index: Integer; AObject: TObject); override;
  4854.     procedure SetUpdateState(Updating: Boolean); override;
  4855.   public
  4856.     constructor Create(AOwner: TTreeNodes);
  4857.     function Add(const S: string): Integer; override;
  4858.     procedure Clear; override;
  4859.     procedure Delete(Index: Integer); override;
  4860.     procedure Insert(Index: Integer; const S: string); override;
  4861.     procedure LoadTreeFromStream(Stream: TStream);
  4862.     procedure SaveTreeToStream(Stream: TStream);
  4863.     property Owner: TTreeNodes read FOwner;
  4864.   end;
  4865.  
  4866. constructor TTreeStrings.Create(AOwner: TTreeNodes);
  4867. begin
  4868.   inherited Create;
  4869.   FOwner := AOwner;
  4870. end;
  4871.  
  4872. function TTreeStrings.Get(Index: Integer): string;
  4873. const
  4874.   TabChar = #9;
  4875. var
  4876.   Level, I: Integer;
  4877.   Node: TTreeNode;
  4878. begin
  4879.   Result := '';
  4880.   Node := Owner.GetNodeFromIndex(Index);
  4881.   Level := Node.Level;
  4882.   for I := 0 to Level - 1 do Result := Result + TabChar;
  4883.   Result := Result + Node.Text;
  4884. end;
  4885.  
  4886. function TTreeStrings.GetBufStart(Buffer: PChar; var Level: Integer): PChar;
  4887. begin
  4888.   Level := 0;
  4889.   while Buffer^ in [' ', #9] do
  4890.   begin
  4891.     Inc(Buffer);
  4892.     Inc(Level);
  4893.   end;
  4894.   Result := Buffer;
  4895. end;
  4896.  
  4897. function TTreeStrings.GetObject(Index: Integer): TObject;
  4898. begin
  4899.   Result := Owner.GetNodeFromIndex(Index).Data;
  4900. end;
  4901.  
  4902. procedure TTreeStrings.PutObject(Index: Integer; AObject: TObject);
  4903. begin
  4904.   Owner.GetNodeFromIndex(Index).Data := AObject;
  4905. end;
  4906.  
  4907. function TTreeStrings.GetCount: Integer;
  4908. begin
  4909.   Result := Owner.Count;
  4910. end;
  4911.  
  4912. procedure TTreeStrings.Clear;
  4913. begin
  4914.   Owner.Clear;
  4915. end;
  4916.  
  4917. procedure TTreeStrings.Delete(Index: Integer);
  4918. begin
  4919.   Owner.GetNodeFromIndex(Index).Delete;
  4920. end;
  4921.  
  4922. procedure TTreeStrings.SetUpdateState(Updating: Boolean);
  4923. begin
  4924.   SendMessage(Owner.Handle, WM_SETREDRAW, Ord(not Updating), 0);
  4925.   if not Updating then Owner.Owner.Refresh;
  4926. end;
  4927.  
  4928. function TTreeStrings.Add(const S: string): Integer;
  4929. var
  4930.   Level, OldLevel, I: Integer;
  4931.   NewStr: string;
  4932.   Node: TTreeNode;
  4933. begin
  4934.   Result := GetCount;
  4935.   if (Length(S) = 1) and (S[1] = Chr($1A)) then Exit;
  4936.   Node := nil;
  4937.   OldLevel := 0;
  4938.   NewStr := GetBufStart(PChar(S), Level);
  4939.   if Result > 0 then
  4940.   begin
  4941.     Node := Owner.GetNodeFromIndex(Result - 1);
  4942.     OldLevel := Node.Level;
  4943.   end;
  4944.   if (Level > OldLevel) or (Node = nil) then
  4945.   begin
  4946.     if Level - OldLevel > 1 then TreeViewError(sInvalidLevel);
  4947.   end
  4948.   else begin
  4949.     for I := OldLevel downto Level do
  4950.     begin
  4951.       Node := Node.Parent;
  4952.       if (Node = nil) and (I - Level > 0) then
  4953.         TreeViewError(sInvalidLevel);
  4954.     end;
  4955.   end;
  4956.   Owner.AddChild(Node, NewStr);
  4957. end;
  4958.  
  4959. procedure TTreeStrings.Insert(Index: Integer; const S: string);
  4960. begin
  4961.   with Owner do
  4962.     Insert(GetNodeFromIndex(Index), S);
  4963. end;
  4964.  
  4965. procedure TTreeStrings.LoadTreeFromStream(Stream: TStream);
  4966. var
  4967.   List: TStringList;
  4968.   ANode, NextNode: TTreeNode;
  4969.   ALevel, i: Integer;
  4970.   CurrStr: string;
  4971. begin
  4972.   List := TStringList.Create;
  4973.   Owner.BeginUpdate;
  4974.   try
  4975.     try
  4976.       Clear;
  4977.       List.LoadFromStream(Stream);
  4978.       ANode := nil;
  4979.       for i := 0 to List.Count - 1 do
  4980.       begin
  4981.         CurrStr := GetBufStart(PChar(List[i]), ALevel);
  4982.         if ANode = nil then
  4983.           ANode := Owner.AddChild(nil, CurrStr)
  4984.         else if ANode.Level = ALevel then
  4985.           ANode := Owner.AddChild(ANode.Parent, CurrStr)
  4986.         else if ANode.Level = (ALevel - 1) then
  4987.           ANode := Owner.AddChild(ANode, CurrStr)
  4988.         else if ANode.Level > ALevel then
  4989.         begin
  4990.           NextNode := ANode.Parent;
  4991.           while NextNode.Level > ALevel do
  4992.             NextNode := NextNode.Parent;
  4993.           ANode := Owner.AddChild(NextNode.Parent, CurrStr);
  4994.         end
  4995.         else TreeViewErrorFmt(sInvalidLevelEx, [ALevel, CurrStr]);
  4996.       end;
  4997.     finally
  4998.       Owner.EndUpdate;
  4999.       List.Free;
  5000.     end;
  5001.   except
  5002.     Owner.Owner.Invalidate;  // force repaint on exception
  5003.     raise;
  5004.   end;
  5005. end;
  5006.  
  5007. procedure TTreeStrings.SaveTreeToStream(Stream: TStream);
  5008. const
  5009.   TabChar = #9;
  5010.   EndOfLine = #13#10;
  5011. var
  5012.   i: Integer;
  5013.   ANode: TTreeNode;
  5014.   NodeStr: string;
  5015. begin
  5016.   if Count > 0 then
  5017.   begin
  5018.     ANode := Owner[0];
  5019.     while ANode <> nil do
  5020.     begin
  5021.       NodeStr := '';
  5022.       for i := 0 to ANode.Level - 1 do NodeStr := NodeStr + TabChar;
  5023.       NodeStr := NodeStr + ANode.Text + EndOfLine;
  5024.       Stream.Write(Pointer(NodeStr)^, Length(NodeStr));
  5025.       ANode := ANode.GetNext;
  5026.     end;
  5027.   end;
  5028. end;
  5029.  
  5030. { TCustomTreeView }
  5031.  
  5032. constructor TCustomTreeView.Create(AOwner: TComponent);
  5033. begin
  5034.   inherited Create(AOwner);
  5035.   ControlStyle := ControlStyle - [csCaptureMouse] + [csDisplayDragImage];
  5036.   Width := 121;
  5037.   Height := 97;
  5038.   TabStop := True;
  5039.   ParentColor := False;
  5040.   FTreeNodes := TTreeNodes.Create(Self);
  5041.   FBorderStyle := bsSingle;
  5042.   FShowButtons := True;
  5043.   FShowRoot := True;
  5044.   FShowLines := True;
  5045.   FHideSelection := True;
  5046.   FDragImage := TImageList.CreateSize(32, 32);
  5047.   FSaveIndent := -1;
  5048.   FEditInstance := MakeObjectInstance(EditWndProc);
  5049.   FImageChangeLink := TChangeLink.Create;
  5050.   FImageChangeLink.OnChange := ImageListChange;
  5051.   FStateChangeLink := TChangeLink.Create;
  5052.   FStateChangeLink.OnChange := ImageListChange;
  5053. end;
  5054.  
  5055. destructor TCustomTreeView.Destroy;
  5056. begin
  5057.   Items.Free;
  5058.   FSaveItems.Free;
  5059.   FDragImage.Free;
  5060.   FMemStream.Free;
  5061.   FreeObjectInstance(FEditInstance);
  5062.   FImageChangeLink.Free;
  5063.   FStateChangeLink.Free;
  5064.   inherited Destroy;
  5065. end;
  5066.  
  5067. procedure TCustomTreeView.CreateParams(var Params: TCreateParams);
  5068. const
  5069.   BorderStyles: array[TBorderStyle] of Integer = (0, WS_BORDER);
  5070.   LineStyles: array[Boolean] of Integer = (0, TVS_HASLINES);
  5071.   RootStyles: array[Boolean] of Integer = (0, TVS_LINESATROOT);
  5072.   ButtonStyles: array[Boolean] of Integer = (0, TVS_HASBUTTONS);
  5073.   EditStyles: array[Boolean] of Integer = (TVS_EDITLABELS, 0);
  5074.   HideSelections: array[Boolean] of Integer = (TVS_SHOWSELALWAYS, 0);
  5075.   DragStyles: array[TDragMode] of Integer = (TVS_DISABLEDRAGDROP, 0);
  5076. begin
  5077.   InitCommonControl(ICC_TREEVIEW_CLASSES);
  5078.   inherited CreateParams(Params);
  5079.   CreateSubClass(Params, WC_TREEVIEW);
  5080.   with Params do
  5081.   begin
  5082.     Style := Style or LineStyles[FShowLines] or BorderStyles[FBorderStyle] or
  5083.       RootStyles[FShowRoot] or ButtonStyles[FShowButtons] or
  5084.       EditStyles[FReadOnly] or HideSelections[FHideSelection] or
  5085.       DragStyles[DragMode];
  5086.     if Ctl3D and NewStyleControls and (FBorderStyle = bsSingle) then
  5087.     begin
  5088.       Style := Style and not WS_BORDER;
  5089.       ExStyle := Params.ExStyle or WS_EX_CLIENTEDGE;
  5090.     end;
  5091.     WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);
  5092.   end;
  5093. end;
  5094.  
  5095. procedure TCustomTreeView.CreateWnd;
  5096. begin
  5097.   inherited CreateWnd;
  5098.   if FMemStream <> nil then
  5099.   begin
  5100.     Items.ReadData(FMemStream);
  5101.     FMemStream.Destroy;
  5102.     FMemStream := nil;
  5103.     SetTopItem(Items.GetNodeFromIndex(FSaveTopIndex));
  5104.     FSaveTopIndex := 0;
  5105.     SetSelection(Items.GetNodeFromIndex(FSaveIndex));
  5106.     FSaveIndex := 0;
  5107.   end;
  5108.   if FSaveIndent <> -1 then Indent := FSaveIndent;
  5109.   if (Images <> nil) and Images.HandleAllocated then
  5110.     SetImageList(Images.Handle, TVSIL_NORMAL);
  5111.   if (StateImages <> nil) and StateImages.HandleAllocated then
  5112.     SetImageList(StateImages.Handle, TVSIL_STATE);
  5113. end;
  5114.  
  5115. procedure TCustomTreeView.DestroyWnd;
  5116. var
  5117.   Node: TTreeNode;
  5118. begin
  5119.   if Items.Count > 0 then
  5120.   begin
  5121.     FMemStream := TMemoryStream.Create;
  5122.     Items.WriteData(FMemStream);
  5123.     FMemStream.Position := 0;
  5124.     Node := GetTopItem;
  5125.     if Node <> nil then FSaveTopIndex := Node.AbsoluteIndex;
  5126.     Node := Selected;
  5127.     if Node <> nil then FSaveIndex := Node.AbsoluteIndex;
  5128.   end;
  5129.   FSaveIndent := Indent;
  5130.   inherited DestroyWnd;
  5131. end;
  5132.  
  5133. procedure TCustomTreeView.EditWndProc(var Message: TMessage);
  5134. begin
  5135.   try
  5136.     with Message do
  5137.     begin
  5138.       case Msg of
  5139.         WM_KEYDOWN,
  5140.         WM_SYSKEYDOWN: if DoKeyDown(TWMKey(Message)) then Exit;
  5141.         WM_CHAR: if DoKeyPress(TWMKey(Message)) then Exit;
  5142.         WM_KEYUP,
  5143.         WM_SYSKEYUP: if DoKeyUp(TWMKey(Message)) then Exit;
  5144.         CN_KEYDOWN,
  5145.         CN_CHAR, CN_SYSKEYDOWN,
  5146.         CN_SYSCHAR:
  5147.           begin
  5148.             WndProc(Message);
  5149.             Exit;
  5150.           end;
  5151.       end;
  5152.       Result := CallWindowProc(FDefEditProc, FEditHandle, Msg, WParam, LParam);
  5153.     end;
  5154.   except
  5155.     Application.HandleException(Self);
  5156.   end;
  5157. end;
  5158.  
  5159. procedure TCustomTreeView.CMColorChanged(var Message: TMessage);
  5160. begin
  5161.   inherited;
  5162.   RecreateWnd;
  5163. end;
  5164.  
  5165. procedure TCustomTreeView.CMCtl3DChanged(var Message: TMessage);
  5166. begin
  5167.   inherited;
  5168.   if FBorderStyle = bsSingle then RecreateWnd;
  5169. end;
  5170.  
  5171. function TCustomTreeView.AlphaSort: Boolean;
  5172. var
  5173.   I: Integer;
  5174. begin
  5175.   if HandleAllocated then
  5176.   begin
  5177.     Result := CustomSort(nil, 0);
  5178.     for I := 0 to Items.Count - 1 do
  5179.       with Items[I] do
  5180.         if HasChildren then AlphaSort;
  5181.   end
  5182.   else Result := False;
  5183. end;
  5184.  
  5185. function TCustomTreeView.CustomSort(SortProc: TTVCompare; Data: Longint): Boolean;
  5186. var
  5187.   SortCB: TTVSortCB;
  5188.   I: Integer;
  5189.   Node: TTreeNode;
  5190. begin
  5191.   Result := False;
  5192.   if HandleAllocated then
  5193.   begin
  5194.     with SortCB do
  5195.     begin
  5196.       if not Assigned(SortProc) then lpfnCompare := @DefaultTreeViewSort
  5197.       else lpfnCompare := SortProc;
  5198.       hParent := TVI_ROOT;
  5199.       lParam := Data;
  5200.       Result := TreeView_SortChildrenCB(Handle, SortCB, 0);
  5201.     end;
  5202.     for I := 0 to Items.Count - 1 do
  5203.     begin
  5204.       Node := Items[I];
  5205.       if Node.HasChildren then Node.CustomSort(SortProc, Data);
  5206.     end;
  5207.   end;
  5208. end;
  5209.  
  5210. procedure TCustomTreeView.SetSortType(Value: TSortType);
  5211. begin
  5212.   if SortType <> Value then
  5213.   begin
  5214.     FSortType := Value;
  5215.     if ((SortType in [stData, stBoth]) and Assigned(OnCompare)) or
  5216.       (SortType in [stText, stBoth]) then
  5217.       AlphaSort;
  5218.   end;
  5219. end;
  5220.  
  5221. procedure TCustomTreeView.SetStyle(Value: Integer; UseStyle: Boolean);
  5222. var
  5223.   Style: Integer;
  5224. begin
  5225.   if HandleAllocated then
  5226.   begin
  5227.     Style := GetWindowLong(Handle, GWL_STYLE);
  5228.     if not UseStyle then Style := Style and not Value
  5229.     else Style := Style or Value;
  5230.     SetWindowLong(Handle, GWL_STYLE, Style);
  5231.   end;
  5232. end;
  5233.  
  5234. procedure TCustomTreeView.SetBorderStyle(Value: TBorderStyle);
  5235. begin
  5236.   if BorderStyle <> Value then
  5237.   begin
  5238.     FBorderStyle := Value;
  5239.     RecreateWnd;
  5240.   end;
  5241. end;
  5242.  
  5243. procedure TCustomTreeView.SetDragMode(Value: TDragMode);
  5244. begin
  5245.   if Value <> DragMode then
  5246.     SetStyle(TVS_DISABLEDRAGDROP, Value = dmManual);
  5247.   inherited;
  5248. end;
  5249.  
  5250. procedure TCustomTreeView.SetButtonStyle(Value: Boolean);
  5251. begin
  5252.   if ShowButtons <> Value then
  5253.   begin
  5254.     FShowButtons := Value;
  5255.     SetStyle(TVS_HASBUTTONS, Value);
  5256.   end;
  5257. end;
  5258.  
  5259. procedure TCustomTreeView.SetLineStyle(Value: Boolean);
  5260. begin
  5261.   if ShowLines <> Value then
  5262.   begin
  5263.     FShowLines := Value;
  5264.     SetStyle(TVS_HASLINES, Value);
  5265.   end;
  5266. end;
  5267.  
  5268. procedure TCustomTreeView.SetRootStyle(Value: Boolean);
  5269. begin
  5270.   if ShowRoot <> Value then
  5271.   begin
  5272.     FShowRoot := Value;
  5273.     SetStyle(TVS_LINESATROOT, Value);
  5274.   end;
  5275. end;
  5276.  
  5277. procedure TCustomTreeView.SetReadOnly(Value: Boolean);
  5278. begin
  5279.   if ReadOnly <> Value then
  5280.   begin
  5281.     FReadOnly := Value;
  5282.     SetStyle(TVS_EDITLABELS, not Value);
  5283.   end;
  5284. end;
  5285.  
  5286. procedure TCustomTreeView.SetHideSelection(Value: Boolean);
  5287. begin
  5288.   if HideSelection <> Value then
  5289.   begin
  5290.     FHideSelection := Value;
  5291.     SetStyle(TVS_SHOWSELALWAYS, not Value);
  5292.     Invalidate;
  5293.   end;
  5294. end;
  5295.  
  5296. function TCustomTreeView.GetNodeAt(X, Y: Integer): TTreeNode;
  5297. var
  5298.   HitTest: TTVHitTestInfo;
  5299. begin
  5300.   with HitTest do
  5301.   begin
  5302.     pt.X := X;
  5303.     pt.Y := Y;
  5304.     if TreeView_HitTest(Handle, HitTest) <> nil then
  5305.       Result := Items.GetNode(HitTest.hItem)
  5306.     else Result := nil;
  5307.   end;
  5308. end;
  5309.  
  5310. function TCustomTreeView.GetHitTestInfoAt(X, Y: Integer): THitTests;
  5311. var
  5312.   HitTest: TTVHitTestInfo;
  5313. begin
  5314.   Result := [];
  5315.   with HitTest do
  5316.   begin
  5317.     pt.X := X;
  5318.     pt.Y := Y;
  5319.     TreeView_HitTest(Handle, HitTest);
  5320.     if (flags and TVHT_ABOVE) <> 0 then Include(Result, htAbove);
  5321.     if (flags and TVHT_BELOW) <> 0 then Include(Result, htBelow);
  5322.     if (flags and TVHT_NOWHERE) <> 0 then Include(Result, htNowhere);
  5323.     if (flags and TVHT_ONITEM) <> 0 then Include(Result, htOnItem);
  5324.     if (flags and TVHT_ONITEMBUTTON) <> 0 then Include(Result, htOnButton);
  5325.     if (flags and TVHT_ONITEMICON) <> 0 then Include(Result, htOnIcon);
  5326.     if (flags and TVHT_ONITEMINDENT) <> 0 then Include(Result, htOnIndent);
  5327.     if (flags and TVHT_ONITEMLABEL) <> 0 then Include(Result, htOnLabel);
  5328.     if (flags and TVHT_ONITEMRIGHT) <> 0 then Include(Result, htOnRight);
  5329.     if (flags and TVHT_ONITEMSTATEICON) <> 0 then Include(Result, htOnStateIcon);
  5330.     if (flags and TVHT_TOLEFT) <> 0 then Include(Result, htToLeft);
  5331.     if (flags and TVHT_TORIGHT) <> 0 then Include(Result, htToRight);
  5332.   end;
  5333. end;
  5334.  
  5335. procedure TCustomTreeView.SetTreeNodes(Value: TTreeNodes);
  5336. begin
  5337.   Items.Assign(Value);
  5338. end;
  5339.  
  5340. procedure TCustomTreeView.SetIndent(Value: Integer);
  5341. begin
  5342.   if Value <> Indent then TreeView_SetIndent(Handle, Value);
  5343. end;
  5344.  
  5345. function TCustomTreeView.GetIndent: Integer;
  5346. begin
  5347.   Result := TreeView_GetIndent(Handle)
  5348. end;
  5349.  
  5350. procedure TCustomTreeView.FullExpand;
  5351. var
  5352.   Node: TTreeNode;
  5353. begin
  5354.   Node := Items.GetFirstNode;
  5355.   while Node <> nil do
  5356.   begin
  5357.     Node.Expand(True);
  5358. //    Node.ExpandItem(True, True);
  5359.     Node := Node.GetNextSibling;
  5360.   end;
  5361. end;
  5362.  
  5363. procedure TCustomTreeView.FullCollapse;
  5364. var
  5365.   Node: TTreeNode;
  5366. begin
  5367.   Node := Items.GetFirstNode;
  5368.   while Node <> nil do
  5369.   begin
  5370.     Node.Collapse(True);
  5371. //    Node.ExpandItem(False, True);
  5372.     Node := Node.GetNextSibling;
  5373.   end;
  5374. end;
  5375.  
  5376. procedure TCustomTreeView.Loaded;
  5377. begin
  5378.   inherited Loaded;
  5379.   if csDesigning in ComponentState then FullExpand;
  5380. end;
  5381.  
  5382. function TCustomTreeView.GetTopItem: TTreeNode;
  5383. begin
  5384.   if HandleAllocated then
  5385.     Result := Items.GetNode(TreeView_GetFirstVisible(Handle))
  5386.   else Result := nil;
  5387. end;
  5388.  
  5389. procedure TCustomTreeView.SetTopItem(Value: TTreeNode);
  5390. begin
  5391.   if HandleAllocated and (Value <> nil) then
  5392.     TreeView_SelectSetFirstVisible(Handle, Value.ItemId);
  5393. end;
  5394.  
  5395. function TCustomTreeView.GetSelection: TTreeNode;
  5396. begin
  5397.   if HandleAllocated then
  5398.   begin
  5399.     if FRightClickSelect and Assigned(FRClickNode) then
  5400.       Result := FRClickNode
  5401.     else
  5402.       Result := Items.GetNode(TreeView_GetSelection(Handle));
  5403.   end
  5404.   else Result := nil;
  5405. end;
  5406.  
  5407. procedure TCustomTreeView.SetSelection(Value: TTreeNode);
  5408. begin
  5409.   if Value <> nil then Value.Selected := True
  5410.   else TreeView_SelectItem(Handle, nil);
  5411. end;
  5412.  
  5413. function TCustomTreeView.GetDropTarget: TTreeNode;
  5414. begin
  5415.   if HandleAllocated then
  5416.   begin
  5417.     Result := Items.GetNode(TreeView_GetDropHilite(Handle));
  5418.     if Result = nil then Result := FLastDropTarget;
  5419.   end
  5420.   else Result := nil;
  5421. end;
  5422.  
  5423. procedure TCustomTreeView.SetDropTarget(Value: TTreeNode);
  5424. begin
  5425.   if HandleAllocated then
  5426.     if Value <> nil then Value.DropTarget := True
  5427.     else TreeView_SelectDropTarget(Handle, nil);
  5428. end;
  5429.  
  5430. function TCustomTreeView.GetNodeFromItem(const Item: TTVItem): TTreeNode;
  5431. begin
  5432.   with Item do
  5433.     if (state and TVIF_PARAM) <> 0 then Result := Pointer(lParam)
  5434.     else Result := Items.GetNode(hItem);
  5435. end;
  5436.  
  5437. function TCustomTreeView.IsEditing: Boolean;
  5438. begin
  5439.   Result := TreeView_GetEditControl(Handle) <> 0;
  5440. end;
  5441.  
  5442. procedure TCustomTreeView.CNNotify(var Message: TWMNotify);
  5443. var
  5444.   Node: TTreeNode;
  5445.   MousePos: TPoint;
  5446. begin
  5447.   with Message.NMHdr^ do
  5448.     case code of
  5449.       TVN_BEGINDRAG:
  5450.         begin
  5451.           FDragged := True;
  5452.           with PNMTreeView(Pointer(Message.NMHdr))^ do
  5453.             FDragNode := GetNodeFromItem(ItemNew);
  5454.         end;
  5455.       TVN_BEGINLABELEDIT:
  5456.         begin
  5457.           with PTVDispInfo(Pointer(Message.NMHdr))^ do
  5458.             if Dragging or not CanEdit(GetNodeFromItem(item)) then
  5459.               Message.Result := 1;
  5460.           if Message.Result = 0 then
  5461.           begin
  5462.             FEditHandle := TreeView_GetEditControl(Handle);
  5463.             FDefEditProc := Pointer(GetWindowLong(FEditHandle, GWL_WNDPROC));
  5464.             SetWindowLong(FEditHandle, GWL_WNDPROC, LongInt(FEditInstance));
  5465.           end;
  5466.         end;
  5467.       TVN_ENDLABELEDIT:
  5468.         with PTVDispInfo(Pointer(Message.NMHdr))^ do
  5469.           Edit(item);
  5470.       TVN_ITEMEXPANDING:
  5471.         if not FManualNotify then
  5472.         begin
  5473.           with PNMTreeView(Pointer(Message.NMHdr))^ do
  5474.           begin
  5475.             Node := GetNodeFromItem(ItemNew);
  5476.             if (action = TVE_EXPAND) and not CanExpand(Node) then
  5477.               Message.Result := 1
  5478.             else if (action = TVE_COLLAPSE) and
  5479.               not CanCollapse(Node) then Message.Result := 1;
  5480.           end;
  5481.         end;
  5482.       TVN_ITEMEXPANDED:
  5483.         if not FManualNotify then
  5484.         begin
  5485.           with PNMTreeView(Pointer(Message.NMHdr))^ do
  5486.           begin
  5487.             Node := GetNodeFromItem(itemNew);
  5488.             if (action = TVE_EXPAND) then Expand(Node)
  5489.             else if (action = TVE_COLLAPSE) then Collapse(Node);
  5490.           end;
  5491.         end;
  5492.       TVN_SELCHANGING:
  5493.         with PNMTreeView(Pointer(Message.NMHdr))^ do
  5494.           if not CanChange(GetNodeFromItem(itemNew)) then
  5495.             Message.Result := 1;
  5496.       TVN_SELCHANGED:
  5497.         with PNMTreeView(Pointer(Message.NMHdr))^ do
  5498.           Change(GetNodeFromItem(itemNew));
  5499.       TVN_DELETEITEM:
  5500.         begin
  5501.           with PNMTreeView(Pointer(Message.NMHdr))^ do
  5502.             Node := GetNodeFromItem(itemOld);
  5503.           if Node <> nil then
  5504.           begin
  5505.             Node.FItemId := nil;
  5506.             Items.Delete(Node);
  5507.           end;
  5508.         end;
  5509.       TVN_SETDISPINFO:
  5510.         with PTVDispInfo(Pointer(Message.NMHdr))^ do
  5511.         begin
  5512.           Node := GetNodeFromItem(item);
  5513.           if (Node <> nil) and ((item.mask and TVIF_TEXT) <> 0) then
  5514.             Node.Text := item.pszText;
  5515.         end;
  5516.       TVN_GETDISPINFO:
  5517.         with PTVDispInfo(Pointer(Message.NMHdr))^ do
  5518.         begin
  5519.           Node := GetNodeFromItem(item);
  5520.           if Node <> nil then
  5521.           begin
  5522.             if (item.mask and TVIF_TEXT) <> 0 then
  5523.               StrLCopy(item.pszText, PChar(Node.Text), item.cchTextMax);
  5524.             if (item.mask and TVIF_IMAGE) <> 0 then
  5525.             begin
  5526.               GetImageIndex(Node);
  5527.               item.iImage := Node.ImageIndex;
  5528.             end;
  5529.             if (item.mask and TVIF_SELECTEDIMAGE) <> 0 then
  5530.             begin
  5531.               GetSelectedIndex(Node);
  5532.               item.iSelectedImage := Node.SelectedIndex;
  5533.             end;
  5534.           end;
  5535.         end;
  5536.       NM_RCLICK:
  5537.         begin
  5538.           if RightClickSelect then
  5539.           begin
  5540.             GetCursorPos(MousePos);
  5541.             with PointToSmallPoint(ScreenToClient(MousePos)) do
  5542.             begin
  5543.               FRClickNode := GetNodeAt(X, Y);
  5544.               Perform(WM_RBUTTONUP, 0, MakeLong(X, Y));
  5545.             end;
  5546.           end
  5547.           else Boolean(FRClickNode) := True;
  5548.         end;
  5549.     end;
  5550. end;
  5551.  
  5552. function TCustomTreeView.GetDragImages: TCustomImageList;
  5553. begin
  5554.   if FDragImage.Count > 0 then
  5555.     Result := FDragImage else
  5556.     Result := nil;
  5557. end;
  5558.  
  5559. procedure TCustomTreeView.WndProc(var Message: TMessage);
  5560. begin
  5561.   if not (csDesigning in ComponentState) and ((Message.Msg = WM_LBUTTONDOWN) or
  5562.     (Message.Msg = WM_LBUTTONDBLCLK)) and not Dragging and (DragMode = dmAutomatic) then
  5563.   begin
  5564.     if not IsControlMouseMsg(TWMMouse(Message)) then
  5565.     begin
  5566.       ControlState := ControlState + [csLButtonDown];
  5567.       Dispatch(Message);
  5568.     end;
  5569.   end
  5570.   else inherited WndProc(Message);
  5571. end;
  5572.  
  5573. procedure TCustomTreeView.DoStartDrag(var DragObject: TDragObject);
  5574. var
  5575.   ImageHandle: HImageList;
  5576.   DragNode: TTreeNode;
  5577.   P: TPoint;
  5578. begin
  5579.   inherited DoStartDrag(DragObject);
  5580.   DragNode := FDragNode;
  5581.   FLastDropTarget := nil;
  5582.   FDragNode := nil;
  5583.   if DragNode = nil then
  5584.   begin
  5585.     GetCursorPos(P);
  5586.     with ScreenToClient(P) do DragNode := GetNodeAt(X, Y);
  5587.   end;
  5588.   if DragNode <> nil then
  5589.   begin
  5590.     ImageHandle := TreeView_CreateDragImage(Handle, DragNode.ItemId);
  5591.     if ImageHandle <> 0 then
  5592.       with FDragImage do
  5593.       begin
  5594.         Handle := ImageHandle;
  5595.         SetDragImage(0, 2, 2);
  5596.       end;
  5597.   end;
  5598. end;
  5599.  
  5600. procedure TCustomTreeView.DoEndDrag(Target: TObject; X, Y: Integer);
  5601. begin
  5602.   inherited DoEndDrag(Target, X, Y);
  5603.   FLastDropTarget := nil;
  5604. end;
  5605.  
  5606. procedure TCustomTreeView.CMDrag(var Message: TCMDrag);
  5607. begin
  5608.   inherited;
  5609.   if Message.Result <> 0 then
  5610.     with Message, DragRec^ do
  5611.       case DragMessage of
  5612.         dmDragMove: with ScreenToClient(Pos) do DoDragOver(Source, X, Y);
  5613.         dmDragLeave:
  5614.           begin
  5615.             TDragObject(Source).HideDragImage;
  5616.             FLastDropTarget := DropTarget;
  5617.             DropTarget := nil;
  5618.             TDragObject(Source).ShowDragImage;
  5619.           end;
  5620.         dmDragDrop: FLastDropTarget := nil;
  5621.       end;
  5622. end;
  5623.  
  5624. procedure TCustomTreeView.DoDragOver(Source: TDragObject; X, Y: Integer);
  5625. var
  5626.   Node: TTreeNode;
  5627. begin
  5628.   Node := GetNodeAt(X, Y);
  5629.   if (Node <> nil) and
  5630.     ((Node <> DropTarget) or (Node = FLastDropTarget)) then
  5631.   begin
  5632.     FLastDropTarget := nil;
  5633.     TDragObject(Source).HideDragImage;
  5634.     Node.DropTarget := True;
  5635.     TDragObject(Source).ShowDragImage;
  5636.   end;
  5637. end;
  5638.  
  5639. procedure TCustomTreeView.GetImageIndex(Node: TTreeNode);
  5640. begin
  5641.   if Assigned(FOnGetImageIndex) then FOnGetImageIndex(Self, Node);
  5642. end;
  5643.  
  5644. procedure TCustomTreeView.GetSelectedIndex(Node: TTreeNode);
  5645. begin
  5646.   if Assigned(FOnGetSelectedIndex) then FOnGetSelectedIndex(Self, Node);
  5647. end;
  5648.  
  5649. function TCustomTreeView.CanChange(Node: TTreeNode): Boolean;
  5650. begin
  5651.   Result := True;
  5652.   if Assigned(FOnChanging) then FOnChanging(Self, Node, Result);
  5653. end;
  5654.  
  5655. procedure TCustomTreeView.Change(Node: TTreeNode);
  5656. begin
  5657.   if Assigned(FOnChange) then FOnChange(Self, Node);
  5658. end;
  5659.  
  5660. procedure TCustomTreeView.Expand(Node: TTreeNode);
  5661. begin
  5662.   if Assigned(FOnExpanded) then FOnExpanded(Self, Node);
  5663. end;
  5664.  
  5665. function TCustomTreeView.CanExpand(Node: TTreeNode): Boolean;
  5666. begin
  5667.   Result := True;
  5668.   if Assigned(FOnExpanding) then FOnExpanding(Self, Node, Result);
  5669. end;
  5670.  
  5671. procedure TCustomTreeView.Collapse(Node: TTreeNode);
  5672. begin
  5673.   if Assigned(FOnCollapsed) then FOnCollapsed(Self, Node);
  5674. end;
  5675.  
  5676. function TCustomTreeView.CanCollapse(Node: TTreeNode): Boolean;
  5677. begin
  5678.   Result := True;
  5679.   if Assigned(FOnCollapsing) then FOnCollapsing(Self, Node, Result);
  5680. end;
  5681.  
  5682. function TCustomTreeView.CanEdit(Node: TTreeNode): Boolean;
  5683. begin
  5684.   Result := True;
  5685.   if Assigned(FOnEditing) then FOnEditing(Self, Node, Result);
  5686. end;
  5687.  
  5688. procedure TCustomTreeView.Edit(const Item: TTVItem);
  5689. var
  5690.   S: string;
  5691.   Node: TTreeNode;
  5692. begin
  5693.   with Item do
  5694.     if pszText <> nil then
  5695.     begin
  5696.       S := pszText;
  5697.       Node := GetNodeFromItem(Item);
  5698.       if Assigned(FOnEdited) then FOnEdited(Self, Node, S);
  5699.       if Node <> nil then Node.Text := S;
  5700.     end;
  5701. end;
  5702.  
  5703. function TCustomTreeView.CreateNode: TTreeNode;
  5704. begin
  5705.   Result := TTreeNode.Create(Items);
  5706. end;
  5707.  
  5708. procedure TCustomTreeView.SetImageList(Value: HImageList; Flags: Integer);
  5709. begin
  5710.   if HandleAllocated then TreeView_SetImageList(Handle, Value, Flags);
  5711. end;
  5712.  
  5713. procedure TCustomTreeView.ImageListChange(Sender: TObject);
  5714. var
  5715.   ImageHandle: HImageList;
  5716. begin
  5717.   if HandleAllocated then
  5718.   begin
  5719.     ImageHandle := TImageList(Sender).Handle;
  5720.     if Sender = Images then
  5721.       SetImageList(ImageHandle, TVSIL_NORMAL)
  5722.     else if Sender = StateImages then
  5723.       SetImageList(ImageHandle, TVSIL_STATE);
  5724.   end;
  5725. end;
  5726.  
  5727. procedure TCustomTreeView.Notification(AComponent: TComponent;
  5728.   Operation: TOperation);
  5729. begin
  5730.   inherited Notification(AComponent, Operation);
  5731.   if Operation = opRemove then
  5732.   begin
  5733.     if AComponent = Images then Images := nil;
  5734.     if AComponent = StateImages then StateImages := nil;
  5735.   end;
  5736. end;
  5737.  
  5738. procedure TCustomTreeView.SetImages(Value: TImageList);
  5739. begin
  5740.   if Images <> nil then
  5741.     Images.UnRegisterChanges(FImageChangeLink);
  5742.   FImages := Value;
  5743.   if Images <> nil then
  5744.   begin
  5745.     Images.RegisterChanges(FImageChangeLink);
  5746.     SetImageList(Images.Handle, TVSIL_NORMAL)
  5747.   end
  5748.   else SetImageList(0, TVSIL_NORMAL);
  5749. end;
  5750.  
  5751. procedure TCustomTreeView.SetStateImages(Value: TImageList);
  5752. begin
  5753.   if StateImages <> nil then
  5754.     StateImages.UnRegisterChanges(FStateChangeLink);
  5755.   FStateImages := Value;
  5756.   if StateImages <> nil then
  5757.   begin
  5758.     StateImages.RegisterChanges(FStateChangeLink);
  5759.     SetImageList(StateImages.Handle, TVSIL_STATE)
  5760.   end
  5761.   else SetImageList(0, TVSIL_STATE);
  5762. end;
  5763.  
  5764. procedure TCustomTreeView.LoadFromFile(const FileName: string);
  5765. var
  5766.   Stream: TStream;
  5767. begin
  5768.   Stream := TFileStream.Create(FileName, fmOpenRead);
  5769.   try
  5770.     LoadFromStream(Stream);
  5771.   finally
  5772.     Stream.Free;
  5773.   end;
  5774. end;
  5775.  
  5776. procedure TCustomTreeView.LoadFromStream(Stream: TStream);
  5777. begin
  5778.   with TTreeStrings.Create(Items) do
  5779.     try
  5780.       LoadTreeFromStream(Stream);
  5781.     finally
  5782.       Free;
  5783.   end;
  5784. end;
  5785.  
  5786. procedure TCustomTreeView.SaveToFile(const FileName: string);
  5787. var
  5788.   Stream: TStream;
  5789. begin
  5790.   Stream := TFileStream.Create(FileName, fmCreate);
  5791.   try
  5792.     SaveToStream(Stream);
  5793.   finally
  5794.     Stream.Free;
  5795.   end;
  5796. end;
  5797.  
  5798. procedure TCustomTreeView.SaveToStream(Stream: TStream);
  5799. begin
  5800.   with TTreeStrings.Create(Items) do
  5801.     try
  5802.       SaveTreeToStream(Stream);
  5803.     finally
  5804.       Free;
  5805.   end;
  5806. end;
  5807.  
  5808. procedure TCustomTreeView.WMRButtonDown(var Message: TWMRButtonDown);
  5809. var
  5810.   MousePos: TPoint;
  5811. begin
  5812.   FRClickNode := nil;
  5813.   try
  5814.     if not RightClickSelect then
  5815.     begin
  5816.       inherited;
  5817.       if FRClickNode <> nil then
  5818.       begin
  5819.         GetCursorPos(MousePos);
  5820.         with PointToSmallPoint(ScreenToClient(MousePos)) do
  5821.           Perform(WM_RBUTTONUP, 0, MakeLong(X, Y));
  5822.       end;
  5823.     end
  5824.     else DefaultHandler(Message);
  5825.   finally
  5826.     FRClickNode := nil;
  5827.  
  5828.   end;
  5829. end;
  5830.  
  5831. procedure TCustomTreeView.WMRButtonUp(var Message: TWMRButtonUp);
  5832.  
  5833.   procedure DoMouseDown(var Message: TWMMouse; Button: TMouseButton;
  5834.     Shift: TShiftState);
  5835.   begin
  5836.     if not (csNoStdEvents in ControlStyle) then
  5837.       with Message do
  5838.         MouseDown(Button, KeysToShiftState(Keys) + Shift, XPos, YPos);
  5839.   end;
  5840.  
  5841. begin
  5842.   if RightClickSelect then DoMouseDown(Message, mbRight, []);
  5843.   inherited;
  5844. end;
  5845.  
  5846. procedure TCustomTreeView.WMLButtonDown(var Message: TWMLButtonDown);
  5847. var
  5848.   Node: TTreeNode;
  5849.   MousePos: TPoint;
  5850. begin
  5851.   FDragged := False;
  5852.   FDragNode := nil;
  5853.   try
  5854.     inherited;
  5855.     if DragMode = dmAutomatic then
  5856.     begin
  5857.       SetFocus;
  5858.       if not FDragged then
  5859.       begin
  5860.         GetCursorPos(MousePos);
  5861.         with PointToSmallPoint(ScreenToClient(MousePos)) do
  5862.           Perform(WM_LBUTTONUP, 0, MakeLong(X, Y));
  5863.       end
  5864.       else begin
  5865.         Node := GetNodeAt(Message.XPos, Message.YPos);
  5866.         if Node <> nil then
  5867.         begin
  5868.           Node.Focused := True;
  5869.           Node.Selected := True;
  5870.           BeginDrag(False);
  5871.         end;
  5872.       end;
  5873.     end;
  5874.   finally
  5875.     FDragNode := nil;
  5876.   end;
  5877. end;
  5878.  
  5879. { TTrackBar }
  5880. constructor TTrackBar.Create(AOwner: TComponent);
  5881. begin
  5882.   inherited Create(AOwner);
  5883.   Width := 150;
  5884.   Height := 45;
  5885.   TabStop := True;
  5886.   FMin := 0;
  5887.   FMax := 10;
  5888.   FLineSize := 1;
  5889.   FPageSize := 2;
  5890.   FFrequency := 1;
  5891.   FTickMarks := tmBottomRight;
  5892.   FTickStyle := tsAuto;
  5893.   FOrientation := trHorizontal;
  5894.   ControlStyle := ControlStyle - [csDoubleClicks];
  5895. end;
  5896.  
  5897. procedure TTrackBar.CreateParams(var Params: TCreateParams);
  5898. const
  5899.   OrientationStyle: array[TTrackbarOrientation] of Longint = (TBS_HORZ, TBS_VERT);
  5900.   TickStyles: array[TTickStyle] of Longint = (TBS_NOTICKS, TBS_AUTOTICKS, 0);
  5901.   ATickMarks: array[TTickMark] of Longint = (TBS_BOTTOM, TBS_TOP, TBS_BOTH);
  5902. begin
  5903.   InitCommonControl(ICC_BAR_CLASSES);
  5904.   inherited CreateParams(Params);
  5905.   CreateSubClass(Params, TRACKBAR_CLASS);
  5906.   with Params do
  5907.   begin
  5908.     Style := Style or OrientationStyle[FOrientation] or
  5909.       TickStyles[FTickStyle] or ATickMarks[FTickMarks] or TBS_ENABLESELRANGE;
  5910.     WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW) or
  5911.       CS_DBLCLKS;
  5912.   end;
  5913. end;
  5914.  
  5915. procedure TTrackBar.CreateWnd;
  5916. begin
  5917.   inherited CreateWnd;
  5918.   if HandleAllocated then
  5919.   begin
  5920.     SendMessage(Handle, TBM_SETLINESIZE, 0, FLineSize);
  5921.     SendMessage(Handle, TBM_SETPAGESIZE, 0, FPageSize);
  5922.     SendMessage(Handle, TBM_SETRANGEMIN, 0, FMin);
  5923.     SendMessage(Handle, TBM_SETRANGEMAX, 0, FMax);
  5924.     UpdateSelection;
  5925.     SendMessage(Handle, TBM_SETPOS, 1, FPosition);
  5926.     SendMessage(Handle, TBM_SETTICFREQ, FFrequency, 1);
  5927.   end;
  5928. end;
  5929.  
  5930. procedure TTrackBar.DestroyWnd;
  5931. begin
  5932.   inherited DestroyWnd;
  5933. end;
  5934.  
  5935. procedure TTrackBar.CNHScroll(var Message: TWMHScroll);
  5936. begin
  5937.   inherited;
  5938.   FPosition := SendMessage(Handle, TBM_GETPOS, 0, 0);
  5939.  
  5940.   if Assigned(FOnChange) then
  5941.     FOnChange(Self);
  5942.   Message.Result := 0;
  5943. end;
  5944.  
  5945. procedure TTrackBar.CNVScroll(var Message: TWMVScroll);
  5946. begin
  5947.   inherited;
  5948.   FPosition := SendMessage(Handle, TBM_GETPOS, 0, 0);
  5949.  
  5950.   if Assigned(FOnChange) then
  5951.     FOnChange(Self);
  5952.   Message.Result := 0;
  5953. end;
  5954.  
  5955. procedure TTrackBar.SetOrientation(Value: TTrackBarOrientation);
  5956. begin
  5957.   if Value <> FOrientation then
  5958.   begin
  5959.     FOrientation := Value;
  5960.     if ComponentState * [csLoading, csUpdating] = [] then
  5961.       SetBounds(Left, Top, Height, Width);
  5962.     RecreateWnd;
  5963.   end;
  5964. end;
  5965.  
  5966. procedure TTrackBar.SetParams(APosition, AMin, AMax: Integer);
  5967. begin
  5968.   if AMax < AMin then
  5969.     raise EInvalidOperation.CreateFmt(SPropertyOutOfRange, [Self.Classname]);
  5970.   if APosition < AMin then APosition := AMin;
  5971.   if APosition > AMax then APosition := AMax;
  5972.   if (FMin <> AMin) then
  5973.   begin
  5974.     FMin := AMin;
  5975.     if HandleAllocated then
  5976.       SendMessage(Handle, TBM_SETRANGEMIN, 1, AMin);
  5977.   end;
  5978.   if (FMax <> AMax) then
  5979.   begin
  5980.     FMax := AMax;
  5981.     if HandleAllocated then
  5982.       SendMessage(Handle, TBM_SETRANGEMAX, 1, AMax);
  5983.   end;
  5984.   if FPosition <> APosition then
  5985.   begin
  5986.     FPosition := APosition;
  5987.     if HandleAllocated then
  5988.       SendMessage(Handle, TBM_SETPOS, 1, APosition);
  5989.   end;
  5990. end;
  5991.  
  5992. procedure TTrackBar.SetPosition(Value: Integer);
  5993. begin
  5994.   SetParams(Value, FMin, FMax);
  5995. end;
  5996.  
  5997. procedure TTrackBar.SetMin(Value: Integer);
  5998. begin
  5999.   SetParams(FPosition, Value, FMax);
  6000. end;
  6001.  
  6002. procedure TTrackBar.SetMax(Value: Integer);
  6003. begin
  6004.   SetParams(FPosition, FMin, Value);
  6005. end;
  6006.  
  6007. procedure TTrackBar.SetFrequency(Value: Integer);
  6008. begin
  6009.   if Value <> FFrequency then
  6010.   begin
  6011.     FFrequency := Value;
  6012.     if HandleAllocated then
  6013.       SendMessage(Handle, TBM_SETTICFREQ, FFrequency, 1);
  6014.   end;
  6015. end;
  6016.  
  6017. procedure TTrackBar.SetTick(Value: Integer);
  6018. begin
  6019.   if HandleAllocated then
  6020.     SendMessage(Handle, TBM_SETTIC, 0, Value);
  6021. end;
  6022.  
  6023. procedure TTrackBar.SetTickStyle(Value: TTickStyle);
  6024. begin
  6025.   if Value <> FTickStyle then
  6026.   begin
  6027.     FTickStyle := Value;
  6028.     RecreateWnd;
  6029.   end;
  6030. end;
  6031.  
  6032. procedure TTrackBar.SetTickMarks(Value: TTickMark);
  6033. begin
  6034.   if Value <> FTickMarks then
  6035.   begin
  6036.     FTickMarks := Value;
  6037.     RecreateWnd;
  6038.   end;
  6039. end;
  6040.  
  6041. procedure TTrackBar.SetLineSize(Value: Integer);
  6042. begin
  6043.   if Value <> FLineSize then
  6044.   begin
  6045.     FLineSize := Value;
  6046.     if HandleAllocated then
  6047.       SendMessage(Handle, TBM_SETLINESIZE, 0, FLineSize);
  6048.   end;
  6049. end;
  6050.  
  6051. procedure TTrackBar.SetPageSize(Value: Integer);
  6052. begin
  6053.   if Value <> FPageSize then
  6054.   begin
  6055.     FPageSize := Value;
  6056.     if HandleAllocated then
  6057.       SendMessage(Handle, TBM_SETPAGESIZE, 0, FPageSize);
  6058.   end;
  6059. end;
  6060.  
  6061. procedure TTrackBar.UpdateSelection;
  6062. begin
  6063.   if HandleAllocated then
  6064.   begin
  6065.     if (FSelStart = 0) and (FSelEnd = 0) then
  6066.       SendMessage(Handle, TBM_CLEARSEL, 1, 0)
  6067.     else
  6068.       SendMessage(Handle, TBM_SETSEL, Integer(True), MakeLong(FSelStart, FSelEnd));
  6069.   end;
  6070. end;
  6071.  
  6072. procedure TTrackBar.SetSelStart(Value: Integer);
  6073. begin
  6074.   if Value <> FSelStart then
  6075.   begin
  6076.     FSelStart := Value;
  6077.     UpdateSelection;
  6078.   end;
  6079. end;
  6080.  
  6081. procedure TTrackBar.SetSelEnd(Value: Integer);
  6082. begin
  6083.   if Value <> FSelEnd then
  6084.   begin
  6085.     FSelEnd := Value;
  6086.     UpdateSelection;
  6087.   end;
  6088. end;
  6089.  
  6090. { TProgressBar }
  6091.  
  6092. constructor TProgressBar.Create(AOwner: TComponent);
  6093. begin
  6094.   inherited Create(AOwner);
  6095.   Width := 150;
  6096.   Height := GetSystemMetrics(SM_CYVSCROLL);
  6097.   FMin := 0;
  6098.   FMax := 100;
  6099.   FStep := 10;
  6100. end;
  6101.  
  6102. procedure TProgressBar.CreateParams(var Params: TCreateParams);
  6103. begin
  6104.   InitCommonControl(ICC_PROGRESS_CLASS);
  6105.   inherited CreateParams(Params);
  6106.   CreateSubClass(Params, PROGRESS_CLASS);
  6107.   with Params.WindowClass do
  6108.     style := style and not (CS_HREDRAW or CS_VREDRAW);
  6109. end;
  6110.  
  6111. procedure TProgressBar.CreateWnd;
  6112. begin
  6113.   inherited CreateWnd;
  6114.   SendMessage(Handle, PBM_SETRANGE32, FMin, FMax);
  6115.   SendMessage(Handle, PBM_SETSTEP, FStep, 0);
  6116.   Position := FPosition;
  6117. end;
  6118.  
  6119. function TProgressBar.GetMin: Integer;
  6120. begin
  6121.   if HandleAllocated then
  6122.     Result := SendMessage(Handle, PBM_GetRange, 1, 0) else
  6123.     Result := FMin;
  6124. end;
  6125.  
  6126. function TProgressBar.GetMax: Integer;
  6127. begin
  6128.   if HandleAllocated then
  6129.     Result := SendMessage(Handle, PBM_GetRange, 0, 0) else
  6130.     Result := FMax;
  6131. end;
  6132.  
  6133. function TProgressBar.GetPosition: Integer;
  6134. begin
  6135.   if HandleAllocated then
  6136.     Result := SendMessage(Handle, PBM_GETPOS, 0, 0) else
  6137.     Result := FPosition;
  6138. end;
  6139.  
  6140. procedure TProgressBar.SetParams(AMin, AMax: Integer);
  6141. begin
  6142.   if AMax < AMin then
  6143.     raise EInvalidOperation.CreateFmt(SPropertyOutOfRange, [Self.Classname]);
  6144.   if (FMin <> AMin) or (FMax <> AMax) then
  6145.   begin
  6146.     if HandleAllocated then
  6147.     begin
  6148.       SendMessage(Handle, PBM_SETRANGE32, AMin, AMax);
  6149.       if FMin > AMin then // since Windows sets Position when increase Min..
  6150.         SendMessage(Handle, PBM_SETPOS, AMin, 0); // set it back if decrease
  6151.     end;
  6152.     FMin := AMin;
  6153.     FMax := AMax;
  6154.   end;
  6155. end;
  6156.  
  6157. procedure TProgressBar.SetMin(Value: Integer);
  6158. begin
  6159.   SetParams(Value, FMax);
  6160. end;
  6161.  
  6162. procedure TProgressBar.SetMax(Value: Integer);
  6163. begin
  6164.   SetParams(FMin, Value);
  6165. end;
  6166.  
  6167. procedure TProgressBar.SetPosition(Value: Integer);
  6168. begin
  6169.   if HandleAllocated then
  6170.     SendMessage(Handle, PBM_SETPOS, Value, 0) else
  6171.     FPosition := Value;
  6172. end;
  6173.  
  6174. procedure TProgressBar.SetStep(Value: Integer);
  6175. begin
  6176.   if Value <> FStep then
  6177.   begin
  6178.     FStep := Value;
  6179.     if HandleAllocated then
  6180.       SendMessage(Handle, PBM_SETSTEP, FStep, 0);
  6181.   end;
  6182. end;
  6183.  
  6184. procedure TProgressBar.StepIt;
  6185. begin
  6186.   if HandleAllocated then
  6187.     SendMessage(Handle, PBM_STEPIT, 0, 0);
  6188. end;
  6189.  
  6190. procedure TProgressBar.StepBy(Delta: Integer);
  6191. begin
  6192.   if HandleAllocated then
  6193.     SendMessage(Handle, PBM_DELTAPOS, Delta, 0);
  6194. end;
  6195.  
  6196. { TTextAttributes }
  6197.  
  6198. constructor TTextAttributes.Create(AOwner: TCustomRichEdit;
  6199.   AttributeType: TAttributeType);
  6200. begin
  6201.   inherited Create;
  6202.   RichEdit := AOwner;
  6203.   FType := AttributeType;
  6204. end;
  6205.  
  6206. procedure TTextAttributes.InitFormat(var Format: TCharFormat);
  6207. begin
  6208.   FillChar(Format, SizeOf(TCharFormat), 0);
  6209.   Format.cbSize := SizeOf(TCharFormat);
  6210. end;
  6211.  
  6212. function TTextAttributes.GetConsistentAttributes: TConsistentAttributes;
  6213. var
  6214.   Format: TCharFormat;
  6215. begin
  6216.   Result := [];
  6217.   if RichEdit.HandleAllocated and (FType = atSelected) then
  6218.   begin
  6219.     InitFormat(Format);
  6220.     SendMessage(RichEdit.Handle, EM_GETCHARFORMAT,
  6221.       WPARAM(FType = atSelected), LPARAM(@Format));
  6222.     with Format do
  6223.     begin
  6224.       if (dwMask and CFM_BOLD) <> 0 then Include(Result, caBold);
  6225.       if (dwMask and CFM_COLOR) <> 0 then Include(Result, caColor);
  6226.       if (dwMask and CFM_FACE) <> 0 then Include(Result, caFace);
  6227.       if (dwMask and CFM_ITALIC) <> 0 then Include(Result, caItalic);
  6228.       if (dwMask and CFM_SIZE) <> 0 then Include(Result, caSize);
  6229.       if (dwMask and CFM_STRIKEOUT) <> 0 then Include(Result, caStrikeOut);
  6230.       if (dwMask and CFM_UNDERLINE) <> 0 then Include(Result, caUnderline);
  6231.       if (dwMask and CFM_PROTECTED) <> 0 then Include(Result, caProtected);
  6232.     end;
  6233.   end;
  6234. end;
  6235.  
  6236. procedure TTextAttributes.GetAttributes(var Format: TCharFormat);
  6237. begin
  6238.   InitFormat(Format);
  6239.   if RichEdit.HandleAllocated then
  6240.     SendMessage(RichEdit.Handle, EM_GETCHARFORMAT,
  6241.       WPARAM(FType = atSelected), LPARAM(@Format));
  6242. end;
  6243.  
  6244. procedure TTextAttributes.SetAttributes(var Format: TCharFormat);
  6245. var
  6246.   Flag: Longint;
  6247. begin
  6248.   if FType = atSelected then Flag := SCF_SELECTION
  6249.   else Flag := 0;
  6250.   if RichEdit.HandleAllocated then
  6251.     SendMessage(RichEdit.Handle, EM_SETCHARFORMAT, Flag, LPARAM(@Format))
  6252. end;
  6253.  
  6254. function TTextAttributes.GetProtected: Boolean;
  6255. var
  6256.   Format: TCharFormat;
  6257. begin
  6258.   GetAttributes(Format);
  6259.   with Format do
  6260.     if (dwEffects and CFE_PROTECTED) <> 0 then
  6261.       Result := True else
  6262.       Result := False;
  6263. end;
  6264.  
  6265. procedure TTextAttributes.SetProtected(Value: Boolean);
  6266. var
  6267.   Format: TCharFormat;
  6268. begin
  6269.   InitFormat(Format);
  6270.   with Format do
  6271.   begin
  6272.     dwMask := CFM_PROTECTED;
  6273.     if Value then dwEffects := CFE_PROTECTED;
  6274.   end;
  6275.   SetAttributes(Format);
  6276. end;
  6277.  
  6278. function TTextAttributes.GetColor: TColor;
  6279. var
  6280.   Format: TCharFormat;
  6281. begin
  6282.   GetAttributes(Format);
  6283.   with Format do
  6284.     if (dwEffects and CFE_AUTOCOLOR) <> 0 then
  6285.       Result := clWindowText else
  6286.       Result := crTextColor;
  6287. end;
  6288.  
  6289. procedure TTextAttributes.SetColor(Value: TColor);
  6290. var
  6291.   Format: TCharFormat;
  6292. begin
  6293.   InitFormat(Format);
  6294.   with Format do
  6295.   begin
  6296.     dwMask := CFM_COLOR;
  6297.     if Value = clWindowText then
  6298.       dwEffects := CFE_AUTOCOLOR else
  6299.       crTextColor := ColorToRGB(Value);
  6300.   end;
  6301.   SetAttributes(Format);
  6302. end;
  6303.  
  6304. function TTextAttributes.GetName: TFontName;
  6305. var
  6306.   Format: TCharFormat;
  6307. begin
  6308.   GetAttributes(Format);
  6309.   Result := Format.szFaceName;
  6310. end;
  6311.  
  6312. function EnumFontProc(var LogFont: TLogFont; var TextMetric: TTextMetric;
  6313.          FontType: Integer; Data: Pointer): Integer; stdcall;
  6314. begin
  6315.   PWord(Data)^ := LogFont.lfCharSet;
  6316.   Result := 0;
  6317. end;
  6318.  
  6319. function GetCharSetOfFontName(const FaceName : string) : integer;
  6320. var
  6321.   Flag: Word;
  6322.   DC: HDC;
  6323. begin
  6324.   result := -1;
  6325.   Flag := $8000;
  6326.   DC := GetDC(0);
  6327.   EnumFontFamilies(DC, PChar(FaceName), @EnumFontProc, LPARAM(@Flag));
  6328.   ReleaseDC(0, DC);
  6329.   if Flag <> $8000 then
  6330.     Result := LoByte(Flag);
  6331. end;
  6332.  
  6333. procedure TTextAttributes.SetName(Value: TFontName);
  6334. var
  6335.   Format: TCharFormat;
  6336. begin
  6337.   InitFormat(Format);
  6338.   with Format do
  6339.   begin
  6340.     dwMask := CFM_FACE;
  6341.     StrPLCopy(szFaceName, Value, SizeOf(szFaceName));
  6342.     bCharSet := GetCharSetOfFontName(Value);
  6343.   end;
  6344.   SetAttributes(Format);
  6345. end;
  6346.  
  6347. function TTextAttributes.GetStyle: TFontStyles;
  6348. var
  6349.   Format: TCharFormat;
  6350. begin
  6351.   Result := [];
  6352.   GetAttributes(Format);
  6353.   with Format do
  6354.   begin
  6355.     if (dwEffects and CFE_BOLD) <> 0 then Include(Result, fsBold);
  6356.     if (dwEffects and CFE_ITALIC) <> 0 then Include(Result, fsItalic);
  6357.     if (dwEffects and CFE_UNDERLINE) <> 0 then Include(Result, fsUnderline);
  6358.     if (dwEffects and CFE_STRIKEOUT) <> 0 then Include(Result, fsStrikeOut);
  6359.   end;
  6360. end;
  6361.  
  6362. procedure TTextAttributes.SetStyle(Value: TFontStyles);
  6363. var
  6364.   Format: TCharFormat;
  6365. begin
  6366.   InitFormat(Format);
  6367.   with Format do
  6368.   begin
  6369.     dwMask := CFM_BOLD or CFM_ITALIC or CFM_UNDERLINE or CFM_STRIKEOUT;
  6370.     if fsBold in Value then dwEffects := dwEffects or CFE_BOLD;
  6371.     if fsItalic in Value then dwEffects := dwEffects or CFE_ITALIC;
  6372.     if fsUnderline in Value then dwEffects := dwEffects or CFE_UNDERLINE;
  6373.     if fsStrikeOut in Value then dwEffects := dwEffects or CFE_STRIKEOUT;
  6374.   end;
  6375.   SetAttributes(Format);
  6376. end;
  6377.  
  6378. function TTextAttributes.GetSize: Integer;
  6379. var
  6380.   Format: TCharFormat;
  6381. begin
  6382.   GetAttributes(Format);
  6383.   Result := Format.yHeight div 20;
  6384. end;
  6385.  
  6386. procedure TTextAttributes.SetSize(Value: Integer);
  6387. var
  6388.   Format: TCharFormat;
  6389. begin
  6390.   InitFormat(Format);
  6391.   with Format do
  6392.   begin
  6393.     dwMask := CFM_SIZE;
  6394.     yHeight := Value * 20;
  6395.   end;
  6396.   SetAttributes(Format);
  6397. end;
  6398.  
  6399. function TTextAttributes.GetHeight: Integer;
  6400. begin
  6401.   Result := MulDiv(Size, RichEdit.FScreenLogPixels, 72);
  6402. end;
  6403.  
  6404. procedure TTextAttributes.SetHeight(Value: Integer);
  6405. begin
  6406.   Size := MulDiv(Value, 72, RichEdit.FScreenLogPixels);
  6407. end;
  6408.  
  6409. function TTextAttributes.GetPitch: TFontPitch;
  6410. var
  6411.   Format: TCharFormat;
  6412. begin
  6413.   GetAttributes(Format);
  6414.   case (Format.bPitchAndFamily and $03) of
  6415.     DEFAULT_PITCH: Result := fpDefault;
  6416.     VARIABLE_PITCH: Result := fpVariable;
  6417.     FIXED_PITCH: Result := fpFixed;
  6418.   else
  6419.     Result := fpDefault;
  6420.   end;
  6421. end;
  6422.  
  6423. procedure TTextAttributes.SetPitch(Value: TFontPitch);
  6424. var
  6425.   Format: TCharFormat;
  6426. begin
  6427.   InitFormat(Format);
  6428.   with Format do
  6429.   begin
  6430.     case Value of
  6431.       fpVariable: Format.bPitchAndFamily := VARIABLE_PITCH;
  6432.       fpFixed: Format.bPitchAndFamily := FIXED_PITCH;
  6433.     else
  6434.       Format.bPitchAndFamily := DEFAULT_PITCH;
  6435.     end;
  6436.   end;
  6437.   SetAttributes(Format);
  6438. end;
  6439.  
  6440. procedure TTextAttributes.Assign(Source: TPersistent);
  6441. begin
  6442.   if Source is TFont then
  6443.   begin
  6444.     Color := TFont(Source).Color;
  6445.     Name := TFont(Source).Name;
  6446.     Style := TFont(Source).Style;
  6447.     Size := TFont(Source).Size;
  6448.     Pitch := TFont(Source).Pitch;
  6449.   end
  6450.   else if Source is TTextAttributes then
  6451.   begin
  6452.     Color := TTextAttributes(Source).Color;
  6453.     Name := TTextAttributes(Source).Name;
  6454.     Style := TTextAttributes(Source).Style;
  6455.     Pitch := TTextAttributes(Source).Pitch;
  6456.   end
  6457.   else inherited Assign(Source);
  6458. end;
  6459.  
  6460. procedure TTextAttributes.AssignTo(Dest: TPersistent);
  6461. begin
  6462.   if Dest is TFont then
  6463.   begin
  6464.     TFont(Dest).Color := Color;
  6465.     TFont(Dest).Name := Name;
  6466.     TFont(Dest).Style := Style;
  6467.     TFont(Dest).Size := Size;
  6468.     TFont(Dest).Pitch := Pitch;
  6469.   end
  6470.   else if Dest is TTextAttributes then
  6471.   begin
  6472.     TTextAttributes(Dest).Color := Color;
  6473.     TTextAttributes(Dest).Name := Name;
  6474.     TTextAttributes(Dest).Style := Style;
  6475.     TTextAttributes(Dest).Pitch := Pitch;
  6476.   end
  6477.   else inherited AssignTo(Dest);
  6478. end;
  6479.  
  6480. { TParaAttributes }
  6481.  
  6482. constructor TParaAttributes.Create(AOwner: TCustomRichEdit);
  6483. begin
  6484.   inherited Create;
  6485.   RichEdit := AOwner;
  6486. end;
  6487.  
  6488. procedure TParaAttributes.InitPara(var Paragraph: TParaFormat);
  6489. begin
  6490.   FillChar(Paragraph, SizeOf(TParaFormat), 0);
  6491.   Paragraph.cbSize := SizeOf(TParaFormat);
  6492. end;
  6493.  
  6494. procedure TParaAttributes.GetAttributes(var Paragraph: TParaFormat);
  6495. begin
  6496.   InitPara(Paragraph);
  6497.   if RichEdit.HandleAllocated then
  6498.     SendMessage(RichEdit.Handle, EM_GETPARAFORMAT, 0, LPARAM(@Paragraph));
  6499. end;
  6500.  
  6501. procedure TParaAttributes.SetAttributes(var Paragraph: TParaFormat);
  6502. begin
  6503.   if RichEdit.HandleAllocated then
  6504.     SendMessage(RichEdit.Handle, EM_SETPARAFORMAT, 0, LPARAM(@Paragraph))
  6505. end;
  6506.  
  6507. function TParaAttributes.GetAlignment: TAlignment;
  6508. var
  6509.   Paragraph: TParaFormat;
  6510. begin
  6511.   GetAttributes(Paragraph);
  6512.   Result := TAlignment(Paragraph.wAlignment - 1);
  6513. end;
  6514.  
  6515. procedure TParaAttributes.SetAlignment(Value: TAlignment);
  6516. var
  6517.   Paragraph: TParaFormat;
  6518. begin
  6519.   InitPara(Paragraph);
  6520.   with Paragraph do
  6521.   begin
  6522.     dwMask := PFM_ALIGNMENT;
  6523.     wAlignment := Ord(Value) + 1;
  6524.   end;
  6525.   SetAttributes(Paragraph);
  6526. end;
  6527.  
  6528. function TParaAttributes.GetNumbering: TNumberingStyle;
  6529. var
  6530.   Paragraph: TParaFormat;
  6531. begin
  6532.   GetAttributes(Paragraph);
  6533.   Result := TNumberingStyle(Paragraph.wNumbering);
  6534. end;
  6535.  
  6536. procedure TParaAttributes.SetNumbering(Value: TNumberingStyle);
  6537. var
  6538.   Paragraph: TParaFormat;
  6539. begin
  6540.   case Value of
  6541.     nsBullet: if LeftIndent < 10 then LeftIndent := 10;
  6542.     nsNone: LeftIndent := 0;
  6543.   end;
  6544.   InitPara(Paragraph);
  6545.   with Paragraph do
  6546.   begin
  6547.     dwMask := PFM_NUMBERING;
  6548.     wNumbering := Ord(Value);
  6549.   end;
  6550.   SetAttributes(Paragraph);
  6551. end;
  6552.  
  6553. function TParaAttributes.GetFirstIndent: Longint;
  6554. var
  6555.   Paragraph: TParaFormat;
  6556. begin
  6557.   GetAttributes(Paragraph);
  6558.   Result := Paragraph.dxStartIndent div 20
  6559. end;
  6560.  
  6561. procedure TParaAttributes.SetFirstIndent(Value: Longint);
  6562. var
  6563.   Paragraph: TParaFormat;
  6564. begin
  6565.   InitPara(Paragraph);
  6566.   with Paragraph do
  6567.   begin
  6568.     dwMask := PFM_STARTINDENT;
  6569.     dxStartIndent := Value * 20;
  6570.   end;
  6571.   SetAttributes(Paragraph);
  6572. end;
  6573.  
  6574. function TParaAttributes.GetLeftIndent: Longint;
  6575. var
  6576.   Paragraph: TParaFormat;
  6577. begin
  6578.   GetAttributes(Paragraph);
  6579.   Result := Paragraph.dxOffset div 20;
  6580. end;
  6581.  
  6582. procedure TParaAttributes.SetLeftIndent(Value: Longint);
  6583. var
  6584.   Paragraph: TParaFormat;
  6585. begin
  6586.   InitPara(Paragraph);
  6587.   with Paragraph do
  6588.   begin
  6589.     dwMask := PFM_OFFSET;
  6590.     dxOffset := Value * 20;
  6591.   end;
  6592.   SetAttributes(Paragraph);
  6593. end;
  6594.  
  6595. function TParaAttributes.GetRightIndent: Longint;
  6596. var
  6597.   Paragraph: TParaFormat;
  6598. begin
  6599.   GetAttributes(Paragraph);
  6600.   Result := Paragraph.dxRightIndent div 20;
  6601. end;
  6602.  
  6603. procedure TParaAttributes.SetRightIndent(Value: Longint);
  6604. var
  6605.   Paragraph: TParaFormat;
  6606. begin
  6607.   InitPara(Paragraph);
  6608.   with Paragraph do
  6609.   begin
  6610.     dwMask := PFM_RIGHTINDENT;
  6611.     dxRightIndent := Value * 20;
  6612.   end;
  6613.   SetAttributes(Paragraph);
  6614. end;
  6615.  
  6616. function TParaAttributes.GetTab(Index: Byte): Longint;
  6617. var
  6618.   Paragraph: TParaFormat;
  6619. begin
  6620.   GetAttributes(Paragraph);
  6621.   Result := Paragraph.rgxTabs[Index] div 20;
  6622. end;
  6623.  
  6624. procedure TParaAttributes.SetTab(Index: Byte; Value: Longint);
  6625. var
  6626.   Paragraph: TParaFormat;
  6627. begin
  6628.   GetAttributes(Paragraph);
  6629.   with Paragraph do
  6630.   begin
  6631.     rgxTabs[Index] := Value * 20;
  6632.     dwMask := PFM_TABSTOPS;
  6633.     if cTabCount < Index then cTabCount := Index;
  6634.     SetAttributes(Paragraph);
  6635.   end;
  6636. end;
  6637.  
  6638. function TParaAttributes.GetTabCount: Integer;
  6639. var
  6640.   Paragraph: TParaFormat;
  6641. begin
  6642.   GetAttributes(Paragraph);
  6643.   Result := Paragraph.cTabCount;
  6644. end;
  6645.  
  6646. procedure TParaAttributes.SetTabCount(Value: Integer);
  6647. var
  6648.   Paragraph: TParaFormat;
  6649. begin
  6650.   GetAttributes(Paragraph);
  6651.   with Paragraph do
  6652.   begin
  6653.     dwMask := PFM_TABSTOPS;
  6654.     cTabCount := Value;
  6655.     SetAttributes(Paragraph);
  6656.   end;
  6657. end;
  6658.  
  6659. procedure TParaAttributes.Assign(Source: TPersistent);
  6660. var
  6661.   I: Integer;
  6662. begin
  6663.   if Source is TParaAttributes then
  6664.   begin
  6665.     Alignment := TParaAttributes(Source).Alignment;
  6666.     FirstIndent := TParaAttributes(Source).FirstIndent;
  6667.     LeftIndent := TParaAttributes(Source).LeftIndent;
  6668.     RightIndent := TParaAttributes(Source).RightIndent;
  6669.     Numbering := TParaAttributes(Source).Numbering;
  6670.     for I := 0 to MAX_TAB_STOPS - 1 do
  6671.       Tab[I] := TParaAttributes(Source).Tab[I];
  6672.   end
  6673.   else inherited Assign(Source);
  6674. end;
  6675.  
  6676. { TConversion }
  6677.  
  6678. function TConversion.ConvertReadStream(Stream: TStream; Buffer: PChar; BufSize: Integer): Integer;
  6679. begin
  6680.   Result := Stream.Read(Buffer^, BufSize);
  6681. end;
  6682.  
  6683. function TConversion.ConvertWriteStream(Stream: TStream; Buffer: PChar; BufSize: Integer): Integer;
  6684. begin
  6685.   Result := Stream.Write(Buffer^, BufSize);
  6686. end;
  6687.  
  6688. { TRichEditStrings }
  6689.  
  6690. const
  6691.   ReadError = $0001;
  6692.   WriteError = $0002;
  6693.   NoError = $0000;
  6694.  
  6695. type
  6696.   TSelection = record
  6697.     StartPos, EndPos: Integer;
  6698.   end;
  6699.  
  6700.   TRichEditStrings = class(TStrings)
  6701.   private
  6702.     RichEdit: TCustomRichEdit;
  6703.     FPlainText: Boolean;
  6704.     FConverter: TConversion;
  6705.     procedure EnableChange(const Value: Boolean);
  6706.   protected
  6707.     function Get(Index: Integer): string; override;
  6708.     function GetCount: Integer; override;
  6709.     procedure Put(Index: Integer; const S: string); override;
  6710.     procedure SetUpdateState(Updating: Boolean); override;
  6711.     procedure SetTextStr(const Value: string); override;
  6712.   public
  6713.     procedure Clear; override;
  6714.     procedure AddStrings(Strings: TStrings); override;
  6715.     procedure Delete(Index: Integer); override;
  6716.     procedure Insert(Index: Integer; const S: string); override;
  6717.     procedure LoadFromFile(const FileName: string); override;
  6718.     procedure LoadFromStream(Stream: TStream); override;
  6719.     procedure SaveToFile(const FileName: string); override;
  6720.     procedure SaveToStream(Stream: TStream); override;
  6721.     property PlainText: Boolean read FPlainText write FPlainText;
  6722.   end;
  6723.  
  6724. procedure TRichEditStrings.AddStrings(Strings: TStrings);
  6725. var
  6726.   SelChange: TNotifyEvent;
  6727. begin
  6728.   SelChange := RichEdit.OnSelectionChange;
  6729.   RichEdit.OnSelectionChange := nil;
  6730.   try
  6731.     inherited AddStrings(Strings);
  6732.   finally
  6733.     RichEdit.OnSelectionChange := SelChange;
  6734.   end;
  6735. end;
  6736.  
  6737. function TRichEditStrings.GetCount: Integer;
  6738. begin
  6739.   Result := SendMessage(RichEdit.Handle, EM_GETLINECOUNT, 0, 0);
  6740.   if SendMessage(RichEdit.Handle, EM_LINELENGTH, SendMessage(RichEdit.Handle,
  6741.     EM_LINEINDEX, Result - 1, 0), 0) = 0 then Dec(Result);
  6742. end;
  6743.  
  6744. function TRichEditStrings.Get(Index: Integer): string;
  6745. var
  6746.   Text: array[0..4095] of Char;
  6747.   L: Integer;
  6748. begin
  6749.   Word((@Text)^) := SizeOf(Text);
  6750.   L := SendMessage(RichEdit.Handle, EM_GETLINE, Index, Longint(@Text));
  6751.   if (Text[L - 2] = #13) and (Text[L - 1] = #10) then Dec(L, 2);
  6752.   SetString(Result, Text, L);
  6753. end;
  6754.  
  6755. procedure TRichEditStrings.Put(Index: Integer; const S: string);
  6756. var
  6757.   Selection: TCharRange;
  6758. begin
  6759.   if Index >= 0 then
  6760.   begin
  6761.     Selection.cpMin := SendMessage(RichEdit.Handle, EM_LINEINDEX, Index, 0);
  6762.     if Selection.cpMin <> -1 then
  6763.     begin
  6764.       Selection.cpMax := Selection.cpMin +
  6765.         SendMessage(RichEdit.Handle, EM_LINELENGTH, Selection.cpMin, 0);
  6766.       SendMessage(RichEdit.Handle, EM_EXSETSEL, 0, Longint(@Selection));
  6767.       SendMessage(RichEdit.Handle, EM_REPLACESEL, 0, Longint(PChar(S)));
  6768.     end;
  6769.   end;
  6770. end;
  6771.  
  6772. procedure TRichEditStrings.Insert(Index: Integer; const S: string);
  6773. var
  6774.   L: Integer;
  6775.   Selection: TCharRange;
  6776.   Fmt: PChar;
  6777.   Str: string;
  6778. begin
  6779.   if Index >= 0 then
  6780.   begin
  6781.     Selection.cpMin := SendMessage(RichEdit.Handle, EM_LINEINDEX, Index, 0);
  6782.     if Selection.cpMin >= 0 then Fmt := '%s'#13#10
  6783.     else begin
  6784.       Selection.cpMin :=
  6785.         SendMessage(RichEdit.Handle, EM_LINEINDEX, Index - 1, 0);
  6786.       if Selection.cpMin < 0 then Exit;
  6787.       L := SendMessage(RichEdit.Handle, EM_LINELENGTH, Selection.cpMin, 0);
  6788.       if L = 0 then Exit;
  6789.       Inc(Selection.cpMin, L);
  6790.       Fmt := #13#10'%s';
  6791.     end;
  6792.     Selection.cpMax := Selection.cpMin;
  6793.     SendMessage(RichEdit.Handle, EM_EXSETSEL, 0, Longint(@Selection));
  6794.     Str := Format(Fmt, [S]);
  6795.     SendMessage(RichEdit.Handle, EM_REPLACESEL, 0, LongInt(PChar(Str)));
  6796.     if RichEdit.SelStart <> (Selection.cpMax + Length(Str)) then
  6797.       raise EOutOfResources.Create(sRichEditInsertError);
  6798.   end;
  6799. end;
  6800.  
  6801. procedure TRichEditStrings.Delete(Index: Integer);
  6802. const
  6803.   Empty: PChar = '';
  6804. var
  6805.   Selection: TCharRange;
  6806. begin
  6807.   if Index < 0 then Exit;
  6808.   Selection.cpMin := SendMessage(RichEdit.Handle, EM_LINEINDEX, Index, 0);
  6809.   if Selection.cpMin <> -1 then
  6810.   begin
  6811.     Selection.cpMax := SendMessage(RichEdit.Handle, EM_LINEINDEX, Index + 1, 0);
  6812.     if Selection.cpMax = -1 then
  6813.       Selection.cpMax := Selection.cpMin +
  6814.         SendMessage(RichEdit.Handle, EM_LINELENGTH, Selection.cpMin, 0);
  6815.     SendMessage(RichEdit.Handle, EM_EXSETSEL, 0, Longint(@Selection));
  6816.     SendMessage(RichEdit.Handle, EM_REPLACESEL, 0, Longint(Empty));
  6817.   end;
  6818. end;
  6819.  
  6820. procedure TRichEditStrings.Clear;
  6821. begin
  6822.   RichEdit.Clear;
  6823. end;
  6824.  
  6825. procedure TRichEditStrings.SetUpdateState(Updating: Boolean);
  6826. begin
  6827.   SendMessage(RichEdit.Handle, WM_SETREDRAW, Ord(not Updating), 0);
  6828.   if not Updating then begin
  6829.     RichEdit.Refresh;
  6830.     RichEdit.Perform(CM_TEXTCHANGED, 0, 0);
  6831.   end;
  6832. end;
  6833.  
  6834. procedure TRichEditStrings.EnableChange(const Value: Boolean);
  6835. var
  6836.   EventMask: Longint;
  6837. begin
  6838.   with RichEdit do
  6839.   begin
  6840.     if Value then
  6841.       EventMask := SendMessage(Handle, EM_GETEVENTMASK, 0, 0) or ENM_CHANGE
  6842.     else
  6843.       EventMask := SendMessage(Handle, EM_GETEVENTMASK, 0, 0) and not ENM_CHANGE;
  6844.     SendMessage(Handle, EM_SETEVENTMASK, 0, EventMask);
  6845.   end;
  6846. end;
  6847.  
  6848. procedure TRichEditStrings.SetTextStr(const Value: string);
  6849. begin
  6850.   EnableChange(False);
  6851.   try
  6852.     inherited SetTextStr(Value);
  6853.   finally
  6854.     EnableChange(True);
  6855.   end;
  6856. end;
  6857.  
  6858. function AdjustLineBreaks(Dest, Source: PChar): Integer; assembler;
  6859. asm
  6860.         PUSH    ESI
  6861.         PUSH    EDI
  6862.         MOV     EDI,EAX
  6863.         MOV     ESI,EDX
  6864.         MOV     EDX,EAX
  6865.         CLD
  6866. @@1:    LODSB
  6867. @@2:    OR      AL,AL
  6868.         JE      @@4
  6869.         CMP     AL,0AH
  6870.         JE      @@3
  6871.         STOSB
  6872.         CMP     AL,0DH
  6873.         JNE     @@1
  6874.         MOV     AL,0AH
  6875.         STOSB
  6876.         LODSB
  6877.         CMP     AL,0AH
  6878.         JE      @@1
  6879.         JMP     @@2
  6880. @@3:    MOV     EAX,0A0DH
  6881.         STOSW
  6882.         JMP     @@1
  6883. @@4:    STOSB
  6884.         LEA     EAX,[EDI-1]
  6885.         SUB     EAX,EDX
  6886.         POP     EDI
  6887.         POP     ESI
  6888. end;
  6889.  
  6890. function StreamSave(dwCookie: Longint; pbBuff: PByte;
  6891.   cb: Longint; var pcb: Longint): Longint; stdcall;
  6892. var
  6893.   StreamInfo: PRichEditStreamInfo;
  6894. begin
  6895.   Result := NoError;
  6896.   StreamInfo := PRichEditStreamInfo(Pointer(dwCookie));
  6897.   try
  6898.     pcb := 0;
  6899.     if StreamInfo^.Converter <> nil then
  6900.       pcb := StreamInfo^.Converter.ConvertWriteStream(StreamInfo^.Stream, PChar(pbBuff), cb);
  6901.   except
  6902.     Result := WriteError;
  6903.   end;
  6904. end;
  6905.  
  6906. function StreamLoad(dwCookie: Longint; pbBuff: PByte;
  6907.   cb: Longint; var pcb: Longint): Longint; stdcall;
  6908. var
  6909.   Buffer, pBuff: PChar;
  6910.   StreamInfo: PRichEditStreamInfo;
  6911. begin
  6912.   Result := NoError;
  6913.   StreamInfo := PRichEditStreamInfo(Pointer(dwCookie));
  6914.   Buffer := StrAlloc(cb + 1);
  6915.   try
  6916.     cb := cb div 2;
  6917.     pcb := 0;
  6918.     pBuff := Buffer + cb;
  6919.     try
  6920.       if StreamInfo^.Converter <> nil then
  6921.         pcb := StreamInfo^.Converter.ConvertReadStream(StreamInfo^.Stream, pBuff, cb);
  6922.       if pcb > 0 then
  6923.       begin
  6924.         pBuff[pcb] := #0;
  6925.         if pBuff[pcb - 1] = #13 then pBuff[pcb - 1] := #0;
  6926.         pcb := AdjustLineBreaks(Buffer, pBuff);
  6927.         Move(Buffer^, pbBuff^, pcb);
  6928.       end;
  6929.     except
  6930.       Result := ReadError;
  6931.     end;
  6932.   finally
  6933.     StrDispose(Buffer);
  6934.   end;
  6935. end;
  6936.  
  6937. procedure TRichEditStrings.LoadFromStream(Stream: TStream);
  6938. var
  6939.   EditStream: TEditStream;
  6940.   Position: Longint;
  6941.   TextType: Longint;
  6942.   StreamInfo: TRichEditStreamInfo;
  6943.   Converter: TConversion;
  6944. begin
  6945.   StreamInfo.Stream := Stream;
  6946.   if FConverter <> nil then
  6947.     Converter := FConverter else
  6948.     Converter := RichEdit.DefaultConverter.Create;
  6949.   StreamInfo.Converter := Converter;
  6950.   try
  6951.     with EditStream do
  6952.     begin
  6953.       dwCookie := LongInt(Pointer(@StreamInfo));
  6954.       pfnCallBack := @StreamLoad;
  6955.       dwError := 0;
  6956.     end;
  6957.     Position := Stream.Position;
  6958.     if PlainText then TextType := SF_TEXT
  6959.     else TextType := SF_RTF;
  6960.     SendMessage(RichEdit.Handle, EM_STREAMIN, TextType, Longint(@EditStream));
  6961.     if (TextType = SF_RTF) and (EditStream.dwError <> 0) then
  6962.     begin
  6963.       Stream.Position := Position;
  6964.       if PlainText then TextType := SF_RTF
  6965.       else TextType := SF_TEXT;
  6966.       SendMessage(RichEdit.Handle, EM_STREAMIN, TextType, Longint(@EditStream));
  6967.       if EditStream.dwError <> 0 then
  6968.         raise EOutOfResources.Create(sRichEditLoadFail);
  6969.     end;
  6970.   finally
  6971.     if FConverter = nil then Converter.Free;
  6972.   end;
  6973. end;
  6974.  
  6975. procedure TRichEditStrings.SaveToStream(Stream: TStream);
  6976. var
  6977.   EditStream: TEditStream;
  6978.   TextType: Longint;
  6979.   StreamInfo: TRichEditStreamInfo;
  6980.   Converter: TConversion;
  6981. begin
  6982.   if FConverter <> nil then
  6983.     Converter := FConverter else
  6984.     Converter := RichEdit.DefaultConverter.Create;
  6985.   StreamInfo.Stream := Stream;
  6986.   StreamInfo.Converter := Converter;
  6987.   try
  6988.     with EditStream do
  6989.     begin
  6990.       dwCookie := LongInt(Pointer(@StreamInfo));
  6991.       pfnCallBack := @StreamSave;
  6992.       dwError := 0;
  6993.     end;
  6994.     if PlainText then TextType := SF_TEXT
  6995.     else TextType := SF_RTF;
  6996.     SendMessage(RichEdit.Handle, EM_STREAMOUT, TextType, Longint(@EditStream));
  6997.     if EditStream.dwError <> 0 then
  6998.       raise EOutOfResources.Create(sRichEditSaveFail);
  6999.   finally
  7000.     if FConverter = nil then Converter.Free;
  7001.   end;
  7002. end;
  7003.  
  7004. procedure TRichEditStrings.LoadFromFile(const FileName: string);
  7005. var
  7006.   Ext: string;
  7007.   Convert: PConversionFormat;
  7008. begin
  7009.   Ext := AnsiLowerCaseFileName(ExtractFileExt(Filename));
  7010.   System.Delete(Ext, 1, 1);
  7011.   Convert := ConversionFormatList;
  7012.   while Convert <> nil do
  7013.     with Convert^ do
  7014.       if Extension <> Ext then Convert := Next
  7015.       else Break;
  7016.   if Convert = nil then
  7017.     Convert := @TextConversionFormat;
  7018.   FConverter := Convert^.ConversionClass.Create;
  7019.   try
  7020.     inherited LoadFromFile(FileName);
  7021.   except
  7022.     FConverter.Free;
  7023.     FConverter := nil;
  7024.     raise;
  7025.   end;
  7026. end;
  7027.  
  7028. procedure TRichEditStrings.SaveToFile(const FileName: string);
  7029. var
  7030.   Ext: string;
  7031.   Convert: PConversionFormat;
  7032. begin
  7033.   Ext := AnsiLowerCaseFileName(ExtractFileExt(Filename));
  7034.   System.Delete(Ext, 1, 1);
  7035.   Convert := ConversionFormatList;
  7036.   while Convert <> nil do
  7037.     with Convert^ do
  7038.       if Extension <> Ext then Convert := Next
  7039.       else Break;
  7040.   if Convert = nil then
  7041.     Convert := @TextConversionFormat;
  7042.   FConverter := Convert^.ConversionClass.Create;
  7043.   try
  7044.     inherited SaveToFile(FileName);
  7045.   except
  7046.     FConverter.Free;
  7047.     FConverter := nil;
  7048.     raise;
  7049.   end;
  7050. end;
  7051.  
  7052. { TRichEdit }
  7053.  
  7054. constructor TCustomRichEdit.Create(AOwner: TComponent);
  7055. var
  7056.   DC: HDC;
  7057. begin
  7058.   inherited Create(AOwner);
  7059.   FSelAttributes := TTextAttributes.Create(Self, atSelected);
  7060.   FDefAttributes := TTextAttributes.Create(Self, atDefaultText);
  7061.   FParagraph := TParaAttributes.Create(Self);
  7062.   FRichEditStrings := TRichEditStrings.Create;
  7063.   TRichEditStrings(FRichEditStrings).RichEdit := Self;
  7064.   TabStop := True;
  7065.   Width := 185;
  7066.   Height := 89;
  7067.   AutoSize := False;
  7068.   FHideSelection := True;
  7069.   HideScrollBars := True;
  7070.   DC := GetDC(0);
  7071.   FScreenLogPixels := GetDeviceCaps(DC, LOGPIXELSY);
  7072.   DefaultConverter := TConversion;
  7073.   ReleaseDC(0, DC);
  7074. end;
  7075.  
  7076. destructor TCustomRichEdit.Destroy;
  7077. begin
  7078.   FSelAttributes.Free;
  7079.   FDefAttributes.Free;
  7080.   FParagraph.Free;
  7081.   FRichEditStrings.Free;
  7082.   FMemStream.Free;
  7083.   inherited Destroy;
  7084. end;
  7085.  
  7086. procedure TCustomRichEdit.Clear;
  7087. begin
  7088.   inherited Clear;
  7089.   Modified := False;
  7090. end;
  7091.  
  7092. procedure TCustomRichEdit.CreateParams(var Params: TCreateParams);
  7093. const
  7094.   RichEditModuleName = 'RICHED32.DLL';
  7095.   HideScrollBars: array[Boolean] of Longint = (ES_DISABLENOSCROLL, 0);
  7096.   HideSelections: array[Boolean] of Longint = (ES_NOHIDESEL, 0);
  7097. var
  7098.   OldError: Longint;
  7099. begin
  7100.   OldError := SetErrorMode(SEM_NOOPENFILEERRORBOX);
  7101.   FLibHandle := LoadLibrary(RichEditModuleName);
  7102.   if FLibHandle < HINSTANCE_ERROR then FLibHandle := 0;
  7103.   SetErrorMode(OldError);
  7104.   inherited CreateParams(Params);
  7105.   CreateSubClass(Params, 'RICHEDIT');
  7106.   with Params do
  7107.   begin
  7108.     Style := Style or HideScrollBars[FHideScrollBars] or
  7109.       HideSelections[HideSelection];
  7110.     WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);
  7111.   end;
  7112. end;
  7113.  
  7114. procedure TCustomRichEdit.CreateWnd;
  7115. var
  7116.   Plain: Boolean;
  7117.   Format: TCharFormat;
  7118. begin
  7119.   inherited CreateWnd;
  7120.   FillChar(Format, SizeOf(TCharFormat), 0);
  7121.   Format.cbSize := SizeOf(TCharFormat);
  7122.   with Format do
  7123.   begin
  7124.     dwMask := CFM_CHARSET;
  7125.     bCharSet := GetDefFontCharset;
  7126.   end;
  7127.   SendMessage(Handle, EM_SETCHARFORMAT, SCF_DEFAULT, LPARAM(@Format));
  7128.   SendMessage(Handle, EM_SETEVENTMASK, 0,
  7129.     ENM_CHANGE or ENM_SELCHANGE or ENM_REQUESTRESIZE or
  7130.     ENM_PROTECTED);
  7131.   SendMessage(Handle, EM_SETBKGNDCOLOR, 0, ColorToRGB(Color));
  7132.   if FMemStream <> nil then
  7133.   begin
  7134.     Plain := PlainText;
  7135.     PlainText := False;
  7136.     try
  7137.       Lines.LoadFromStream(FMemStream);
  7138.       FMemStream.Free;
  7139.       FMemStream := nil;
  7140.     finally
  7141.       PlainText := Plain;
  7142.     end;
  7143.   end;
  7144.   Modified := FModified;
  7145. end;
  7146.  
  7147. procedure TCustomRichEdit.DestroyWnd;
  7148. var
  7149.   Plain: Boolean;
  7150. begin
  7151.   FModified := Modified;
  7152.   FMemStream := TMemoryStream.Create;
  7153.   Plain := PlainText;
  7154.   PlainText := False;
  7155.   try
  7156.     Lines.SaveToStream(FMemStream);
  7157.     FMemStream.Position := 0;
  7158.   finally
  7159.     PlainText := Plain;
  7160.   end;
  7161.   inherited DestroyWnd;
  7162. end;
  7163.  
  7164. procedure TCustomRichEdit.WMNCDestroy(var Message: TWMNCDestroy);
  7165. begin
  7166.   inherited;
  7167.   if FLibHandle <> 0 then FreeLibrary(FLibHandle);
  7168. end;
  7169.  
  7170. procedure TCustomRichEdit.WMSetFont(var Message: TWMSetFont);
  7171. begin
  7172.   FDefAttributes.Assign(Font);
  7173. end;
  7174.  
  7175. procedure TCustomRichEdit.CMFontChanged(var Message: TMessage);
  7176. begin
  7177.   FDefAttributes.Assign(Font);
  7178. end;
  7179.  
  7180. procedure TCustomRichEdit.DoSetMaxLength(Value: Integer);
  7181. begin
  7182.   SendMessage(Handle, EM_EXLIMITTEXT, 0, Value);
  7183. end;
  7184.  
  7185. function TCustomRichEdit.GetSelLength: Integer;
  7186. var
  7187.   CharRange: TCharRange;
  7188. begin
  7189.   SendMessage(Handle, EM_EXGETSEL, 0, Longint(@CharRange));
  7190.   Result := CharRange.cpMax - CharRange.cpMin;
  7191. end;
  7192.  
  7193. function TCustomRichEdit.GetSelStart: Integer;
  7194. var
  7195.   CharRange: TCharRange;
  7196. begin
  7197.   SendMessage(Handle, EM_EXGETSEL, 0, Longint(@CharRange));
  7198.   Result := CharRange.cpMin;
  7199. end;
  7200.  
  7201. function TCustomRichEdit.GetSelTextBuf(Buffer: PChar; BufSize: Integer): Integer;
  7202. var
  7203.   S: string;
  7204. begin
  7205.   S := GetSelText;
  7206.   Result := Length(S);
  7207.   if BufSize < Length(S) then Result := BufSize;
  7208.   StrPLCopy(Buffer, S, Result);
  7209. end;
  7210.  
  7211. function TCustomRichEdit.GetSelText: string;
  7212. var
  7213.   Length: Integer;
  7214. begin
  7215.   SetLength(Result, GetSelLength + 1);
  7216.   Length := SendMessage(Handle, EM_GETSELTEXT, 0, Longint(PChar(Result)));
  7217.   SetLength(Result, Length);
  7218. end;
  7219.  
  7220. procedure TCustomRichEdit.SetHideScrollBars(Value: Boolean);
  7221. begin
  7222.   if HideScrollBars <> Value then
  7223.   begin
  7224.     FHideScrollBars := value;
  7225.     RecreateWnd;
  7226.   end;
  7227. end;
  7228.  
  7229. procedure TCustomRichEdit.SetHideSelection(Value: Boolean);
  7230. begin
  7231.   if HideSelection <> Value then
  7232.   begin
  7233.     FHideSelection := Value;
  7234.     SendMessage(Handle, EM_HIDESELECTION, Ord(HideSelection), LongInt(True));
  7235.   end;
  7236. end;
  7237.  
  7238. procedure TCustomRichEdit.SetSelAttributes(Value: TTextAttributes);
  7239. begin
  7240.   SelAttributes.Assign(Value);
  7241. end;
  7242.  
  7243. procedure TCustomRichEdit.SetSelLength(Value: Integer);
  7244. var
  7245.   CharRange: TCharRange;
  7246. begin
  7247.   SendMessage(Handle, EM_EXGETSEL, 0, Longint(@CharRange));
  7248.   CharRange.cpMax := CharRange.cpMin + Value;
  7249.   SendMessage(Handle, EM_EXSETSEL, 0, Longint(@CharRange));
  7250.   SendMessage(Handle, EM_SCROLLCARET, 0, 0);
  7251. end;
  7252.  
  7253. procedure TCustomRichEdit.SetDefAttributes(Value: TTextAttributes);
  7254. begin
  7255.   DefAttributes.Assign(Value);
  7256. end;
  7257.  
  7258. function TCustomRichEdit.GetPlainText: Boolean;
  7259. begin
  7260.   Result := TRichEditStrings(Lines).PlainText;
  7261. end;
  7262.  
  7263. procedure TCustomRichEdit.SetPlainText(Value: Boolean);
  7264. begin
  7265.   TRichEditStrings(Lines).PlainText := Value;
  7266. end;
  7267.  
  7268. procedure TCustomRichEdit.CMColorChanged(var Message: TMessage);
  7269. begin
  7270.   inherited;
  7271.   SendMessage(Handle, EM_SETBKGNDCOLOR, 0, ColorToRGB(Color))
  7272. end;
  7273.  
  7274. procedure TCustomRichEdit.SetRichEditStrings(Value: TStrings);
  7275. begin
  7276.   FRichEditStrings.Assign(Value);
  7277. end;
  7278.  
  7279. procedure TCustomRichEdit.SetSelStart(Value: Integer);
  7280. var
  7281.   CharRange: TCharRange;
  7282. begin
  7283.   CharRange.cpMin := Value;
  7284.   CharRange.cpMax := Value;
  7285.   SendMessage(Handle, EM_EXSETSEL, 0, Longint(@CharRange));
  7286. end;
  7287.  
  7288. procedure TCustomRichEdit.Print(const Caption: string);
  7289. var
  7290.   Range: TFormatRange;
  7291.   LastChar, MaxLen, LogX, LogY, OldMap: Integer;
  7292. begin
  7293.   FillChar(Range, SizeOf(TFormatRange), 0);
  7294.   with Printer, Range do
  7295.   begin
  7296.     BeginDoc;
  7297.     hdc := Handle;
  7298.     hdcTarget := hdc;
  7299.     LogX := GetDeviceCaps(Handle, LOGPIXELSX);
  7300.     LogY := GetDeviceCaps(Handle, LOGPIXELSY);
  7301.     if IsRectEmpty(PageRect) then
  7302.     begin
  7303.       rc.right := PageWidth * 1440 div LogX;
  7304.       rc.bottom := PageHeight * 1440 div LogY;
  7305.     end
  7306.     else begin
  7307.       rc.left := PageRect.Left * 1440 div LogX;
  7308.       rc.top := PageRect.Top * 1440 div LogY;
  7309.       rc.right := PageRect.Right * 1440 div LogX;
  7310.       rc.bottom := PageRect.Bottom * 1440 div LogY;
  7311.     end;
  7312.     rcPage := rc;
  7313.     Title := Caption;
  7314.     LastChar := 0;
  7315.     MaxLen := GetTextLen;
  7316.     chrg.cpMax := -1;
  7317.     // ensure printer DC is in text map mode
  7318.     OldMap := SetMapMode(hdc, MM_TEXT);
  7319.     SendMessage(Handle, EM_FORMATRANGE, 0, 0);    // flush buffer
  7320.     try
  7321.       repeat
  7322.         chrg.cpMin := LastChar;
  7323.         LastChar := SendMessage(Self.Handle, EM_FORMATRANGE, 1, Longint(@Range));
  7324.         if (LastChar < MaxLen) and (LastChar <> -1) then NewPage;
  7325.       until (LastChar >= MaxLen) or (LastChar = -1);
  7326.       EndDoc;
  7327.     finally
  7328.       SendMessage(Handle, EM_FORMATRANGE, 0, 0);  // flush buffer
  7329.       SetMapMode(hdc, OldMap);       // restore previous map mode
  7330.     end;
  7331.   end;
  7332. end;
  7333.  
  7334. var
  7335.   Painting: Boolean = False;
  7336.  
  7337. procedure TCustomRichEdit.WMPaint(var Message: TWMPaint);
  7338. var
  7339.   R, R1: TRect;
  7340. begin
  7341.   if GetUpdateRect(Handle, R, True) then
  7342.   begin
  7343.     with ClientRect do R1 := Rect(Right - 3, Top, Right, Bottom);
  7344.     if IntersectRect(R, R, R1) then InvalidateRect(Handle, @R1, True);
  7345.   end;
  7346.   if Painting then
  7347.     Invalidate
  7348.   else begin
  7349.     Painting := True;
  7350.     try
  7351.       inherited;
  7352.     finally
  7353.       Painting := False;
  7354.     end;
  7355.   end;
  7356. end;
  7357.  
  7358. procedure TCustomRichEdit.WMSetCursor(var Message: TWMSetCursor);
  7359. var
  7360.   P: TPoint;
  7361. begin
  7362.   inherited;
  7363.   if Message.Result = 0 then
  7364.   begin
  7365.     Message.Result := 1;
  7366.     GetCursorPos(P);
  7367.     with PointToSmallPoint(P) do
  7368.       case Perform(WM_NCHITTEST, 0, MakeLong(X, Y)) of
  7369.         HTVSCROLL,
  7370.         HTHSCROLL:
  7371.           Windows.SetCursor(Screen.Cursors[crArrow]);
  7372.         HTCLIENT:
  7373.           Windows.SetCursor(Screen.Cursors[crIBeam]);
  7374.       end;
  7375.   end;
  7376. end;
  7377.  
  7378. procedure TCustomRichEdit.CNNotify(var Message: TWMNotify);
  7379. begin
  7380.   with Message.NMHdr^ do
  7381.     case code of
  7382.       EN_SELCHANGE: SelectionChange;
  7383.       EN_REQUESTRESIZE: RequestSize(PReqSize(Pointer(Message.NMHdr))^.rc);
  7384.       EN_SAVECLIPBOARD:
  7385.         with PENSaveClipboard(Pointer(Message.NMHdr))^ do
  7386.           if not SaveClipboard(cObjectCount, cch) then Message.Result := 1;
  7387.       EN_PROTECTED:
  7388.         with PENProtected(Pointer(Message.NMHdr))^.chrg do
  7389.           if not ProtectChange(cpMin, cpMax) then Message.Result := 1;
  7390.     end;
  7391. end;
  7392.  
  7393. function TCustomRichEdit.SaveClipboard(NumObj, NumChars: Integer): Boolean;
  7394. begin
  7395.   Result := True;
  7396.   if Assigned(OnSaveClipboard) then OnSaveClipboard(Self, NumObj, NumChars, Result);
  7397. end;
  7398.  
  7399. function TCustomRichEdit.ProtectChange(StartPos, EndPos: Integer): Boolean;
  7400. begin
  7401.   Result := False;
  7402.   if Assigned(OnProtectChange) then OnProtectChange(Self, StartPos, EndPos, Result);
  7403. end;
  7404.  
  7405. procedure TCustomRichEdit.SelectionChange;
  7406. begin
  7407.   if Assigned(OnSelectionChange) then OnSelectionChange(Self);
  7408. end;
  7409.  
  7410. procedure TCustomRichEdit.RequestSize(const Rect: TRect);
  7411. begin
  7412.   if Assigned(OnResizeRequest) then OnResizeRequest(Self, Rect);
  7413. end;
  7414.  
  7415. function TCustomRichEdit.FindText(const SearchStr: string;
  7416.   StartPos, Length: Integer; Options: TSearchTypes): Integer;
  7417. var
  7418.   Find: TFindText;
  7419.   Flags: Integer;
  7420. begin
  7421.   with Find.chrg do
  7422.   begin
  7423.     cpMin := StartPos;
  7424.     cpMax := cpMin + Length;
  7425.   end;
  7426.   Flags := 0;
  7427.   if stWholeWord in Options then Flags := Flags or FT_WHOLEWORD;
  7428.   if stMatchCase in Options then Flags := Flags or FT_MATCHCASE;
  7429.   Find.lpstrText := PChar(SearchStr);
  7430.   Result := SendMessage(Handle, EM_FINDTEXT, Flags, LongInt(@Find));
  7431. end;
  7432.  
  7433. procedure AppendConversionFormat(const Ext: string; AClass: TConversionClass);
  7434. var
  7435.   NewRec: PConversionFormat;
  7436. begin
  7437.   New(NewRec);
  7438.   with NewRec^ do
  7439.   begin
  7440.     Extension := AnsiLowerCaseFileName(Ext);
  7441.     ConversionClass := AClass;
  7442.     Next := ConversionFormatList;
  7443.   end;
  7444.   ConversionFormatList := NewRec;
  7445. end;
  7446.  
  7447. class procedure TCustomRichEdit.RegisterConversionFormat(const AExtension: string;
  7448.   AConversionClass: TConversionClass);
  7449. begin
  7450.   AppendConversionFormat(AExtension, AConversionClass);
  7451. end;
  7452.  
  7453. { TUpDown }
  7454.  
  7455. constructor TCustomUpDown.Create(AOwner: TComponent);
  7456. begin
  7457.   inherited Create(AOwner);
  7458.   Width := GetSystemMetrics(SM_CXVSCROLL);
  7459.   Height := GetSystemMetrics(SM_CYVSCROLL);
  7460.   Height := Height + (Height div 2);
  7461.   FArrowKeys := True;
  7462.   FMax := 100;
  7463.   FIncrement := 1;
  7464.   FAlignButton := udRight;
  7465.   FOrientation := udVertical;
  7466.   FThousands := True;
  7467.   ControlStyle := ControlStyle - [csDoubleClicks];
  7468. end;
  7469.  
  7470. procedure TCustomUpDown.CreateParams(var Params: TCreateParams);
  7471. begin
  7472.   InitCommonControl(ICC_UPDOWN_CLASS);
  7473.   inherited CreateParams(Params);
  7474.   with Params do
  7475.   begin
  7476.     Style := Style or UDS_SETBUDDYINT;
  7477.     if FAlignButton = udRight then Style := Style or UDS_ALIGNRIGHT
  7478.     else Style := Style or UDS_ALIGNLEFT;
  7479.     if FOrientation = udHorizontal then Style := Style or UDS_HORZ;
  7480.     if FArrowKeys then Style := Style or UDS_ARROWKEYS;
  7481.     if not FThousands then Style := Style or UDS_NOTHOUSANDS;
  7482.     if FWrap then Style := Style or UDS_WRAP;
  7483.   end;
  7484.   CreateSubClass(Params, UPDOWN_CLASS);
  7485.   with Params.WindowClass do
  7486.     style := style and not (CS_HREDRAW or CS_VREDRAW) or CS_DBLCLKS;
  7487. end;
  7488.  
  7489. procedure TCustomUpDown.CreateWnd;
  7490. var
  7491.   OrigWidth: Integer;
  7492.   AccelArray: array [0..0] of TUDAccel;
  7493. begin
  7494.   OrigWidth := Width;  { control resizes width - disallowing user to set width }
  7495.   inherited CreateWnd;
  7496.   Width := OrigWidth;
  7497.   SendMessage(Handle, UDM_SETRANGE, 0, MakeLong(FMax, FMin));
  7498.   SendMessage(Handle, UDM_SETPOS, 0, MakeLong(FPosition, 0));
  7499.   SendMessage(Handle, UDM_GETACCEL, 1, Longint(@AccelArray));
  7500.   AccelArray[0].nInc := FIncrement;
  7501.   SendMessage(Handle, UDM_SETACCEL, 1, Longint(@AccelArray));
  7502.  
  7503.   if FAssociate <> nil then
  7504.   begin
  7505.     UndoAutoResizing(FAssociate);
  7506.     SendMessage(Handle, UDM_SETBUDDY, FAssociate.Handle, 0);
  7507.   end;
  7508. end;
  7509.  
  7510. procedure TCustomUpDown.WMVScroll(var Message: TWMVScroll);
  7511. begin
  7512.   inherited;
  7513.   if Message.ScrollCode = SB_THUMBPOSITION then
  7514.   begin
  7515.     if Message.Pos > FPosition then Click(btNext)
  7516.     else if Message.Pos < FPosition then Click(btPrev);
  7517.     FPosition := Message.Pos;
  7518.   end;
  7519. end;
  7520.  
  7521. procedure TCustomUpDown.WMSize(var Message: TWMSize);
  7522. var
  7523.   R: TRect;
  7524. begin
  7525.   inherited;
  7526.   R := ClientRect;
  7527.   InvalidateRect(Handle, @R, False);
  7528. end;
  7529.  
  7530. procedure TCustomUpDown.WMHScroll(var Message: TWMHScroll);
  7531. begin
  7532.   inherited;
  7533.   if Message.ScrollCode = SB_THUMBPOSITION then
  7534.   begin
  7535.     if Message.Pos > FPosition then Click(btNext)
  7536.     else if Message.Pos < FPosition then Click(btPrev);
  7537.     FPosition := Message.Pos;
  7538.   end;
  7539. end;
  7540.  
  7541. function TCustomUpDown.CanChange: Boolean;
  7542. begin
  7543.   Result := True;
  7544.   if Assigned(FOnChanging) then
  7545.     FOnChanging(Self, Result);
  7546. end;
  7547.  
  7548. procedure TCustomUpDown.CNNotify(var Message: TWMNotify);
  7549. begin
  7550.   with Message.NMHdr^ do
  7551.   begin
  7552.     case code of
  7553.       UDN_DELTAPOS: LongBool(Message.Result) := not CanChange;
  7554.     end;
  7555.   end;
  7556. end;
  7557.  
  7558. procedure TCustomUpDown.Click(Button: TUDBtnType);
  7559. begin
  7560.   if Assigned(FOnClick) then FOnClick(Self, Button);
  7561. end;
  7562.  
  7563. procedure TCustomUpDown.SetAssociate(Value: TWinControl);
  7564. var
  7565.   I: Integer;
  7566.  
  7567.   function IsClass(ClassType: TClass; const Name: string): Boolean;
  7568.   begin
  7569.     Result := True;
  7570.     while ClassType <> nil do
  7571.     begin
  7572.       if ClassType.ClassNameIs(Name) then Exit;
  7573.       ClassType := ClassType.ClassParent;
  7574.     end;
  7575.     Result := False;
  7576.   end;
  7577.  
  7578. begin
  7579.   for I := 0 to Parent.ControlCount - 1 do
  7580.     if (Parent.Controls[I] is TCustomUpDown) and (Parent.Controls[I] <> Self) then
  7581.       if TCustomUpDown(Parent.Controls[I]).Associate = Value then
  7582.         raise Exception.CreateFmt(sUDAssociated,
  7583.           [Value.Name, Parent.Controls[I].Name]);
  7584.  
  7585.   if FAssociate <> nil then { undo the current associate control }
  7586.   begin
  7587.     if HandleAllocated then
  7588.       SendMessage(Handle, UDM_SETBUDDY, 0, 0);
  7589.     FAssociate := nil;
  7590.   end;
  7591.  
  7592.   if (Value <> nil) and (Value.Parent = Self.Parent) and
  7593.     not (Value is TCustomUpDown) and
  7594.     not (Value is TCustomTreeView) and not (Value is TCustomListView) and
  7595.     not IsClass(Value.ClassType, 'TDBEdit') and
  7596.     not IsClass(Value.ClassType, 'TDBMemo') then
  7597.   begin
  7598.     if HandleAllocated then
  7599.     begin
  7600.       UndoAutoResizing(Value);
  7601.       SendMessage(Handle, UDM_SETBUDDY, Value.Handle, 0);
  7602.     end;
  7603.     FAssociate := Value;
  7604.     if Value is TCustomEdit then
  7605.       TCustomEdit(Value).Text := IntToStr(FPosition);
  7606.   end;
  7607. end;
  7608.  
  7609. procedure TCustomUpDown.UndoAutoResizing(Value: TWinControl);
  7610. var
  7611.   OrigWidth, NewWidth, DeltaWidth: Integer;
  7612.   OrigLeft, NewLeft, DeltaLeft: Integer;
  7613. begin
  7614.   { undo Window's auto-resizing }
  7615.   OrigWidth := Value.Width;
  7616.   OrigLeft := Value.Left;
  7617.   SendMessage(Handle, UDM_SETBUDDY, Value.Handle, 0);
  7618.   NewWidth := Value.Width;
  7619.   NewLeft := Value.Left;
  7620.   DeltaWidth := OrigWidth - NewWidth;
  7621.   DeltaLeft := NewLeft - OrigLeft;
  7622.   Value.Width := OrigWidth + DeltaWidth;
  7623.   Value.Left := OrigLeft - DeltaLeft;
  7624. end;
  7625.  
  7626. procedure TCustomUpDown.Notification(AComponent: TComponent;
  7627.   Operation: TOperation);
  7628. begin
  7629.   inherited Notification(AComponent, Operation);
  7630.   if (Operation = opRemove) and (AComponent = FAssociate) then
  7631.     if HandleAllocated then
  7632.     begin
  7633.       SendMessage(Handle, UDM_SETBUDDY, 0, 0);
  7634.       FAssociate := nil;
  7635.     end;
  7636. end;
  7637.  
  7638. function TCustomUpDown.GetPosition: SmallInt;
  7639. begin
  7640.   if HandleAllocated then
  7641.   begin
  7642.     Result := LoWord(SendMessage(Handle, UDM_GETPOS, 0, 0));
  7643.     FPosition := Result;
  7644.   end
  7645.   else Result := FPosition;
  7646. end;
  7647.  
  7648. procedure TCustomUpDown.SetMin(Value: SmallInt);
  7649. begin
  7650.   if Value <> FMin then
  7651.   begin
  7652.     FMin := Value;
  7653.     if HandleAllocated then
  7654.       SendMessage(Handle, UDM_SETRANGE, 0, MakeLong(FMax, FMin));
  7655.   end;
  7656. end;
  7657.  
  7658. procedure TCustomUpDown.SetMax(Value: SmallInt);
  7659. begin
  7660.   if Value <> FMax then
  7661.   begin
  7662.     FMax := Value;
  7663.     if HandleAllocated then
  7664.       SendMessage(Handle, UDM_SETRANGE, 0, MakeLong(FMax, FMin));
  7665.   end;
  7666. end;
  7667.  
  7668. procedure TCustomUpDown.SetIncrement(Value: Integer);
  7669. var
  7670.   AccelArray: array [0..0] of TUDAccel;
  7671. begin
  7672.   if Value <> FIncrement then
  7673.   begin
  7674.     FIncrement := Value;
  7675.     if HandleAllocated then
  7676.     begin
  7677.       SendMessage(Handle, UDM_GETACCEL, 1, Longint(@AccelArray));
  7678.       AccelArray[0].nInc := Value;
  7679.       SendMessage(Handle, UDM_SETACCEL, 1, Longint(@AccelArray));
  7680.     end;
  7681.   end;
  7682. end;
  7683.  
  7684. procedure TCustomUpDown.SetPosition(Value: SmallInt);
  7685. begin
  7686.   if Value <> FPosition then
  7687.   begin
  7688.     FPosition := Value;
  7689.     if (csDesigning in ComponentState) and (FAssociate <> nil) then
  7690.       if FAssociate is TCustomEdit then
  7691.         TCustomEdit(FAssociate).Text := IntToStr(FPosition);
  7692.     if HandleAllocated then
  7693.       SendMessage(Handle, UDM_SETPOS, 0, MakeLong(FPosition, 0));
  7694.   end;
  7695. end;
  7696.  
  7697. procedure TCustomUpDown.SetOrientation(Value: TUDOrientation);
  7698. begin
  7699.   if Value <> FOrientation then
  7700.   begin
  7701.     FOrientation := Value;
  7702.     if ComponentState * [csLoading, csUpdating] = [] then
  7703.       SetBounds(Left, Top, Height, Width);
  7704.     if HandleAllocated then
  7705.       SendMessage(Handle, UDM_SETBUDDY, 0, 0);
  7706.     RecreateWnd;
  7707.   end;
  7708. end;
  7709.  
  7710. procedure TCustomUpDown.SetAlignButton(Value: TUDAlignButton);
  7711. begin
  7712.   if Value <> FAlignButton then
  7713.   begin
  7714.     FAlignButton := Value;
  7715.     if HandleAllocated then
  7716.       SendMessage(Handle, UDM_SETBUDDY, 0, 0);
  7717.     RecreateWnd;
  7718.   end;
  7719. end;
  7720.  
  7721. procedure TCustomUpDown.SetArrowKeys(Value: Boolean);
  7722. begin
  7723.   if Value <> FArrowKeys then
  7724.   begin
  7725.     FArrowKeys := Value;
  7726.     if HandleAllocated then
  7727.       SendMessage(Handle, UDM_SETBUDDY, 0, 0);
  7728.     RecreateWnd;
  7729.   end;
  7730. end;
  7731.  
  7732. procedure TCustomUpDown.SetThousands(Value: Boolean);
  7733. begin
  7734.   if Value <> FThousands then
  7735.   begin
  7736.     FThousands := Value;
  7737.     if HandleAllocated then
  7738.       SendMessage(Handle, UDM_SETBUDDY, 0, 0);
  7739.     RecreateWnd;
  7740.   end;
  7741. end;
  7742.  
  7743. procedure TCustomUpDown.SetWrap(Value: Boolean);
  7744. begin
  7745.   if Value <> FWrap then
  7746.   begin
  7747.     FWrap := Value;
  7748.     if HandleAllocated then
  7749.       SendMessage(Handle, UDM_SETBUDDY, 0, 0);
  7750.     RecreateWnd;
  7751.   end;
  7752. end;
  7753.  
  7754. { THotKey }
  7755.  
  7756. constructor TCustomHotKey.Create(AOwner: TComponent);
  7757. begin
  7758.   inherited Create(AOwner);
  7759.   Width := 121;
  7760.   Height := 25;
  7761.   TabStop := True;
  7762.   ParentColor := False;
  7763.   FAutoSize := True;
  7764.   FInvalidKeys := [hcNone, hcShift];
  7765.   FModifiers := [hkAlt];
  7766.   FHotKey := $0041;     // default - 'Alt+A'
  7767.   AdjustHeight;
  7768. end;
  7769.  
  7770. procedure TCustomHotKey.CreateParams(var Params: TCreateParams);
  7771. begin
  7772.   InitCommonControl(ICC_HOTKEY_CLASS);
  7773.   inherited CreateParams(Params);
  7774.   CreateSubClass(Params, HOTKEYCLASS);
  7775.   with Params.WindowClass do
  7776.     style := style and not (CS_HREDRAW or CS_VREDRAW);
  7777. end;
  7778.  
  7779. procedure TCustomHotKey.CreateWnd;
  7780. begin
  7781.   inherited CreateWnd;
  7782.   SendMessage(Handle, HKM_SETRULES, Byte(FInvalidKeys), MakeLong(Byte(FModifiers), 0));
  7783.   SendMessage(Handle, HKM_SETHOTKEY, MakeWord(Byte(FHotKey), Byte(FModifiers)), 0);
  7784. end;
  7785.  
  7786. procedure TCustomHotKey.SetAutoSize(Value: Boolean);
  7787. begin
  7788.   if FAutoSize <> Value then
  7789.   begin
  7790.     FAutoSize := Value;
  7791.     UpdateHeight;
  7792.   end;
  7793. end;
  7794.  
  7795. procedure TCustomHotKey.SetModifiers(Value: THKModifiers);
  7796. begin
  7797.   if Value <> FModifiers then
  7798.   begin
  7799.     FModifiers := Value;
  7800.     SendMessage(Handle, HKM_SETRULES, Byte(FInvalidKeys), MakeLong(Byte(Value), 0));
  7801.     SendMessage(Handle, HKM_SETHOTKEY, MakeWord(Byte(FHotKey), Byte(FModifiers)), 0);
  7802.   end;
  7803. end;
  7804.  
  7805. procedure TCustomHotKey.SetInvalidKeys(Value: THKInvalidKeys);
  7806. begin
  7807.   if Value <> FInvalidKeys then
  7808.   begin
  7809.     FInvalidKeys := Value;
  7810.     SendMessage(Handle, HKM_SETRULES, Byte(Value), MakeLong(Byte(FModifiers), 0));
  7811.     SendMessage(Handle, HKM_SETHOTKEY, MakeWord(Byte(FHotKey), Byte(FModifiers)), 0);
  7812.   end;
  7813. end;
  7814.  
  7815. function TCustomHotKey.GetHotKey: TShortCut;
  7816. var
  7817.   HK: Longint;
  7818. begin
  7819.   HK := SendMessage(Handle, HKM_GETHOTKEY, 0, 0);
  7820.   Result := HotKeyToShortCut(HK);
  7821. end;
  7822.  
  7823. procedure TCustomHotKey.SetHotKey(Value: TShortCut);
  7824. begin
  7825.   ShortCutToHotKey(Value);
  7826.   SendMessage(Handle, HKM_SETHOTKEY, MakeWord(Byte(FHotKey), Byte(FModifiers)), 0);
  7827. end;
  7828.  
  7829. procedure TCustomHotKey.UpdateHeight;
  7830. begin
  7831.   if FAutoSize then
  7832.   begin
  7833.     ControlStyle := ControlStyle + [csFixedHeight];
  7834.     AdjustHeight;
  7835.   end else
  7836.     ControlStyle := ControlStyle - [csFixedHeight];
  7837. end;
  7838.  
  7839. procedure TCustomHotKey.AdjustHeight;
  7840. var
  7841.   DC: HDC;
  7842.   SaveFont: HFont;
  7843.   I: Integer;
  7844.   SysMetrics, Metrics: TTextMetric;
  7845. begin
  7846.   DC := GetDC(0);
  7847.   GetTextMetrics(DC, SysMetrics);
  7848.   SaveFont := SelectObject(DC, Font.Handle);
  7849.   GetTextMetrics(DC, Metrics);
  7850.   SelectObject(DC, SaveFont);
  7851.   ReleaseDC(0, DC);
  7852.   if NewStyleControls then
  7853.   begin
  7854.     if Ctl3D then I := 8 else I := 6;
  7855.     I := GetSystemMetrics(SM_CYBORDER) * I;
  7856.   end else
  7857.   begin
  7858.     I := SysMetrics.tmHeight;
  7859.     if I > Metrics.tmHeight then I := Metrics.tmHeight;
  7860.     I := I div 4 + GetSystemMetrics(SM_CYBORDER) * 4;
  7861.   end;
  7862.   Height := Metrics.tmHeight + I;
  7863. end;
  7864.  
  7865. procedure TCustomHotKey.ShortCutToHotKey(Value: TShortCut);
  7866. begin
  7867.   FHotKey := Value and not (scShift + scCtrl + scAlt);
  7868.   FModifiers := [];
  7869.   if Value and scShift <> 0 then Include(FModifiers, hkShift);
  7870.   if Value and scCtrl <> 0 then Include(FModifiers, hkCtrl);
  7871.   if Value and scAlt <> 0 then Include(FModifiers, hkAlt);
  7872. end;
  7873.  
  7874. function TCustomHotKey.HotKeyToShortCut(Value: Longint): TShortCut;
  7875. begin
  7876.   Byte(FModifiers) := LoWord(HiByte(Value));
  7877.   FHotKey := LoWord(LoByte(Value));
  7878.   Result := FHotKey;
  7879.   if hkShift in FModifiers then Inc(Result, scShift);
  7880.   if hkCtrl in FModifiers then Inc(Result, scCtrl);
  7881.   if hkAlt in FModifiers then Inc(Result, scAlt);
  7882. end;
  7883.  
  7884. { TListColumn }
  7885.  
  7886. constructor TListColumn.Create(Collection: TCollection);
  7887. var
  7888.   Column: TLVColumn;
  7889. begin
  7890.   inherited Create(Collection);
  7891.   FWidth := 50;
  7892.   FAlignment := taLeftJustify;
  7893.   with Column do
  7894.   begin
  7895.     mask := LVCF_FMT or LVCF_WIDTH;
  7896.     fmt := LVCFMT_LEFT;
  7897.     cx := FWidth;
  7898.   end;
  7899.   ListView_InsertColumn(TListColumns(Collection).Owner.Handle, Index, Column);
  7900. end;
  7901.  
  7902. destructor TListColumn.Destroy;
  7903. begin
  7904.   if TListColumns(Collection).Owner.HandleAllocated then
  7905.     ListView_DeleteColumn(TListColumns(Collection).Owner.Handle, Index);
  7906.   inherited Destroy;
  7907. end;
  7908.  
  7909. procedure TListColumn.DefineProperties(Filer: TFiler);
  7910. begin
  7911.   inherited DefineProperties(Filer);
  7912.   Filer.DefineProperty('WidthType', ReadData, WriteData,
  7913.     WidthType <= ColumnTextWidth);
  7914. end;
  7915.  
  7916. procedure TListColumn.ReadData(Reader: TReader);
  7917. begin
  7918.   with Reader do
  7919.   begin
  7920.     ReadListBegin;
  7921.     Width := TWidth(ReadInteger);
  7922.     ReadListEnd;
  7923.   end;
  7924. end;
  7925.  
  7926. procedure TListColumn.WriteData(Writer: TWriter);
  7927. begin
  7928.   with Writer do
  7929.   begin
  7930.     WriteListBegin;
  7931.     WriteInteger(Ord(WidthType));
  7932.     WriteListEnd;
  7933.   end;
  7934. end;
  7935.  
  7936. procedure TListColumn.DoChange;
  7937. var
  7938.   I: Integer;
  7939. begin
  7940. //  Figure out why this breaks stuff:
  7941. //  (Collection as TListColumns).FOwner.HandleNeeded;
  7942.   for I := 0 to Collection.Count - 1 do
  7943.     if TListColumn(Collection.Items[I]).WidthType <= ColumnTextWidth then Break;
  7944.   Changed(I <> Collection.Count);
  7945. end;
  7946.  
  7947. procedure TListColumn.SetCaption(const Value: string);
  7948. begin
  7949.   if FCaption <> Value then
  7950.   begin
  7951.     FCaption := Value;
  7952.     DoChange;
  7953.   end;
  7954. end;
  7955.  
  7956. function TListColumn.GetWidth: TWidth;
  7957. var
  7958.   Column: TLVColumn;
  7959.   ListView: TCustomListView;
  7960. begin
  7961.   ListView := TListColumns(Collection).Owner;
  7962.   if ListView.HandleAllocated then
  7963.   begin
  7964.     Column.mask := LVCF_WIDTH;
  7965.     ListView_GetColumn(ListView.Handle, Index, Column);
  7966.     Result := Column.cx;
  7967.     if WidthType > ColumnTextWidth then FWidth := Result;
  7968.   end
  7969.   else Result := 0;
  7970. end;
  7971.  
  7972. procedure TListColumn.SetWidth(Value: TWidth);
  7973. begin
  7974.   if Width <> Value then
  7975.   begin
  7976.     FWidth := Value;
  7977.     DoChange;
  7978.   end;
  7979. end;
  7980.  
  7981. procedure TListColumn.SetAlignment(Value: TAlignment);
  7982. begin
  7983.   if (Alignment <> Value) and (Index <> 0) then
  7984.   begin
  7985.     FAlignment := Value;
  7986.     Changed(False);
  7987.     TListColumns(Collection).Owner.Repaint;
  7988.   end;
  7989. end;
  7990.  
  7991. procedure TListColumn.Assign(Source: TPersistent);
  7992. var
  7993.   Column: TListColumn;
  7994. begin
  7995.   if Source is TListColumn then
  7996.   begin
  7997.     Column := TListColumn(Source);
  7998.     Alignment := Column.Alignment;
  7999.     Width := Column.Width;
  8000.     Caption := Column.Caption;
  8001.   end
  8002.   else inherited Assign(Source);
  8003. end;
  8004.  
  8005. function TListColumn.GetDisplayName: string;
  8006. begin
  8007.   Result := Caption;
  8008.   if Result = '' then Result := inherited GetDisplayName;
  8009. end;
  8010.  
  8011. { TListColumns }
  8012.  
  8013. constructor TListColumns.Create(AOwner: TCustomListView);
  8014. begin
  8015.   inherited Create(TListColumn);
  8016.   FOwner := AOwner;
  8017. end;
  8018.  
  8019. function TListColumns.GetItem(Index: Integer): TListColumn;
  8020. begin
  8021.   Result := TListColumn(inherited GetItem(Index));
  8022. end;
  8023.  
  8024. procedure TListColumns.SetItem(Index: Integer; Value: TListColumn);
  8025. begin
  8026.   inherited SetItem(Index, Value);
  8027. end;
  8028.  
  8029. function TListColumns.Add: TListColumn;
  8030. begin
  8031.   Result := TListColumn(inherited Add);
  8032. end;
  8033.  
  8034. function TListColumns.GetOwner: TPersistent;
  8035. begin
  8036.   Result := FOwner;
  8037. end;
  8038.  
  8039. procedure TListColumns.Update(Item: TCollectionItem);
  8040. begin
  8041.   if Item <> nil then Owner.UpdateColumn(Item.Index)
  8042.   else Owner.UpdateColumns;
  8043. end;
  8044.  
  8045. { TSubItems }
  8046.  
  8047. type
  8048.   TSubItems = class(TStringList)
  8049.   private
  8050.     FOwner: TListItem;
  8051.     procedure SetColumnWidth(Index: Integer);
  8052.   protected
  8053.     function GetHandle: HWND;
  8054.     procedure SetUpdateState(Updating: Boolean); override;
  8055.   public
  8056.     constructor Create(AOwner: TListItem);
  8057.     function Add(const S: string): Integer; override;
  8058.     procedure Insert(Index: Integer; const S: string); override;
  8059.     property Handle: HWND read GetHandle;
  8060.     property Owner: TListItem read FOwner;
  8061.   end;
  8062.  
  8063. constructor TSubItems.Create(AOwner: TListItem);
  8064. begin
  8065.   inherited Create;
  8066.   FOwner := AOwner;
  8067. end;
  8068.  
  8069. function TSubItems.GetHandle: HWND;
  8070. begin
  8071.   Result := Owner.Owner.Handle;
  8072. end;
  8073.  
  8074. procedure TSubItems.SetColumnWidth(Index: Integer);
  8075. var
  8076.   ListView: TCustomListView;
  8077. begin
  8078.   ListView := Owner.ListView;
  8079.   if ListView.ColumnsShowing and
  8080.     (ListView.Columns.Count > Index) and
  8081.     (ListView.Column[Index].WidthType = ColumnTextWidth) then
  8082.     ListView.UpdateColumn(Index);
  8083. end;
  8084.  
  8085. function TSubItems.Add(const S: string): Integer;
  8086. begin
  8087.   Result := inherited Add(S);
  8088.   ListView_SetItemText(Handle, Owner.Index, Count, LPSTR_TEXTCALLBACK);
  8089.   SetColumnWidth(Count);
  8090. end;
  8091.  
  8092. procedure TSubItems.Insert(Index: Integer; const S: string);
  8093. begin
  8094.   inherited Insert(Index, S);
  8095.   ListView_SetItemText(Handle, Owner.Index, Index + 1, LPSTR_TEXTCALLBACK);
  8096.   SetColumnWidth(Index + 1);
  8097. end;
  8098.  
  8099. procedure TSubItems.SetUpdateState(Updating: Boolean);
  8100. begin
  8101.   Owner.Owner.SetUpdateState(Updating);
  8102. end;
  8103.  
  8104. { TListItem }
  8105.  
  8106. constructor TListItem.Create(AOwner: TListItems);
  8107. begin
  8108.   FOwner := AOwner;
  8109.   FSubItems := TSubItems.Create(Self);
  8110.   FOverlayIndex := -1;
  8111.   FStateIndex := -1;
  8112. end;
  8113.  
  8114. destructor TListItem.Destroy;
  8115. begin
  8116.   FDeleting := True;
  8117.   if Owner.Owner.FLastDropTarget = Self then
  8118.     Owner.Owner.FLastDropTarget := nil;
  8119.   if ListView.HandleAllocated then ListView_DeleteItem(Handle, Index);
  8120.   FSubItems.Free;
  8121.   inherited Destroy;
  8122. end;
  8123.  
  8124. function TListItem.GetListView: TCustomListView;
  8125. begin
  8126.   Result := Owner.Owner;
  8127. end;
  8128.  
  8129. procedure TListItem.Delete;
  8130. begin
  8131.   if not FDeleting then Free;
  8132. end;
  8133.  
  8134. function TListItem.GetHandle: HWND;
  8135. begin
  8136.   Result := ListView.Handle;
  8137. end;
  8138.  
  8139. procedure TListItem.MakeVisible(PartialOK: Boolean);
  8140. begin
  8141.   ListView_EnsureVisible(Handle, Index, PartialOK);
  8142. end;
  8143.  
  8144. function TListItem.GetChecked: Boolean;
  8145. begin
  8146.   Result := Listview.Checkboxes and (ListView_GetCheckState(Handle, Index) <> 0);
  8147. end;
  8148.  
  8149. procedure TListItem.SetChecked(Value: Boolean);
  8150. begin
  8151.   ListView_SetCheckState(Handle, Index, Value);
  8152. end;
  8153.  
  8154. function TListItem.GetLeft: Integer;
  8155. begin
  8156.   Result := GetPosition.X;
  8157. end;
  8158.  
  8159. procedure TListItem.SetLeft(Value: Integer);
  8160. begin
  8161.   SetPosition(Point(Value, 0));
  8162. end;
  8163.  
  8164. function TListItem.GetTop: Integer;
  8165. begin
  8166.   Result := GetPosition.Y;
  8167. end;
  8168.  
  8169. procedure TListItem.SetTop(Value: Integer);
  8170. begin
  8171.   SetPosition(Point(0, Value));
  8172. end;
  8173.  
  8174. procedure TListItem.Update;
  8175. begin
  8176.   ListView_Update(Handle, Index);
  8177. end;
  8178.  
  8179. procedure TListItem.SetCaption(const Value: string);
  8180. begin
  8181.   FCaption := Value;
  8182.   ListView_SetItemText(Handle, Index, 0, LPSTR_TEXTCALLBACK);
  8183.   if ListView.ColumnsShowing and
  8184.     (ListView.Columns.Count > 0) and
  8185.     (ListView.Column[0].WidthType <= ColumnTextWidth) then
  8186.     ListView.UpdateColumns;
  8187.   if ListView.SortType in [stBoth, stText] then ListView.AlphaSort;
  8188. end;
  8189.  
  8190. procedure TListItem.SetData(Value: Pointer);
  8191. begin
  8192.   FData := Value;
  8193.   if ListView.SortType in [stBoth, stData] then ListView.AlphaSort;
  8194. end;
  8195.  
  8196. function TListItem.EditCaption: Boolean;
  8197. begin
  8198.   Result := ListView_EditLabel(Handle, Index) <> 0;
  8199. end;
  8200.  
  8201. procedure TListItem.CancelEdit;
  8202. begin
  8203.   ListView_EditLabel(Handle, -1);
  8204. end;
  8205.  
  8206. function TListItem.GetState(Index: Integer): Boolean;
  8207. var
  8208.   Mask: Integer;
  8209. begin
  8210.   case Index of
  8211.     0: Mask := LVIS_CUT;
  8212.     1: Mask := LVIS_DROPHILITED;
  8213.     2: Mask := LVIS_FOCUSED;
  8214.     3: Mask := LVIS_SELECTED;
  8215.   else
  8216.     Mask := 0;
  8217.   end;
  8218.   Result := ListView_GetItemState(Handle, Self.Index, Mask) and Mask <> 0;
  8219. end;
  8220.  
  8221. procedure TListItem.SetState(Index: Integer; State: Boolean);
  8222. var
  8223.   Mask: Integer;
  8224.   Data: Integer;
  8225. begin
  8226.   case Index of
  8227.     0: Mask := LVIS_CUT;
  8228.     1: Mask := LVIS_DROPHILITED;
  8229.     2: Mask := LVIS_FOCUSED;
  8230.     3: Mask := LVIS_SELECTED;
  8231.   else
  8232.     Mask := 0;
  8233.   end;
  8234.   if State then Data := Mask
  8235.   else Data := 0;
  8236.   ListView_SetItemState(Handle, Self.Index, Data, Mask);
  8237. end;
  8238.  
  8239. procedure TListItem.SetImage(Index: Integer; Value: Integer);
  8240. var
  8241.   Item: TLVItem;
  8242. begin
  8243.   case Index of
  8244.     0:
  8245.       begin
  8246.         FImageIndex := Value;
  8247.         with Item do
  8248.         begin
  8249.           mask := LVIF_IMAGE;
  8250.           iImage := I_IMAGECALLBACK;
  8251.           iItem := Self.Index;
  8252.           iSubItem := 0;
  8253.         end;
  8254.         ListView_SetItem(Handle, Item);
  8255.       end;
  8256.     1:
  8257.       begin
  8258.         FOverlayIndex := Value;
  8259.         ListView_SetItemState(Handle, Self.Index,
  8260.           IndexToOverlayMask(OverlayIndex + 1), LVIS_OVERLAYMASK);
  8261.       end;
  8262.     2:
  8263.       begin
  8264.         FStateIndex := Value;
  8265.         ListView_SetItemState(Handle, Self.Index,
  8266.           IndexToStateImageMask(StateIndex + 1), LVIS_STATEIMAGEMASK);
  8267.       end;
  8268.   end;
  8269.   ListView.UpdateItems(Self.Index, Self.Index);
  8270. end;
  8271.  
  8272. procedure TListItem.Assign(Source: TPersistent);
  8273. begin
  8274.   if Source is TListItem then
  8275.     with Source as TListItem do
  8276.     begin
  8277.       Self.Caption := Caption;
  8278.       Self.Data := Data;
  8279.       Self.ImageIndex := ImageIndex;
  8280.       Self.OverlayIndex := OverlayIndex;
  8281.       Self.StateIndex := StateIndex;
  8282.       Self.SubItems := SubItems;
  8283.     end
  8284.   else inherited Assign(Source);
  8285. end;
  8286.  
  8287. function TListItem.IsEqual(Item: TListItem): Boolean;
  8288. begin
  8289.   Result := (Caption = Item.Caption) and (Data = Item.Data);
  8290. end;
  8291.  
  8292. procedure TListItem.SetSubItems(Value: TStrings);
  8293. begin
  8294.   if Value <> nil then FSubItems.Assign(Value);
  8295. end;
  8296.  
  8297. function TListItem.GetIndex: Integer;
  8298. begin
  8299.   Result := Owner.IndexOf(Self);
  8300. end;
  8301.  
  8302. function TListItem.GetPosition: TPoint;
  8303. begin
  8304.   ListView_GetItemPosition(Handle, Index, Result);
  8305. end;
  8306.  
  8307. procedure TListItem.SetPosition(const Value: TPoint);
  8308. begin
  8309.   if ListView.ViewStyle in [vsSmallIcon, vsIcon] then
  8310.     ListView_SetItemPosition32(Handle, Index, Value.X, Value.Y);
  8311. end;
  8312.  
  8313. function TListItem.DisplayRect(Code: TDisplayCode): TRect;
  8314. const
  8315.   Codes: array[TDisplayCode] of Longint = (LVIR_BOUNDS, LVIR_ICON, LVIR_LABEL,
  8316.     LVIR_SELECTBOUNDS);
  8317. begin
  8318.   ListView_GetItemRect(Handle, Index, Result, Codes[Code]);
  8319. end;
  8320.  
  8321. { TListItems }
  8322.  
  8323. type
  8324.   PItemHeader = ^TItemHeader;
  8325.   TItemHeader = packed record
  8326.     Size, Count: Integer;
  8327.     Items: record end;
  8328.   end;
  8329.   PItemInfo = ^TItemInfo;
  8330.   TItemInfo = packed record
  8331.     ImageIndex: Integer;
  8332.     StateIndex: Integer;
  8333.     OverlayIndex: Integer;
  8334.     SubItemCount: Integer;
  8335.     Data: Pointer;
  8336.     Caption: string[255];
  8337.   end;
  8338.   ShortStr = string[255];
  8339.   PShortStr = ^ShortStr;
  8340.  
  8341. constructor TListItems.Create(AOwner: TCustomListView);
  8342. begin
  8343.   inherited Create;
  8344.   FOwner := AOwner;
  8345. end;
  8346.  
  8347. destructor TListItems.Destroy;
  8348. begin
  8349.   Clear;
  8350.   inherited Destroy;
  8351. end;
  8352.  
  8353. function TListItems.Add: TListItem;
  8354. begin
  8355.   Result := Owner.CreateListItem;
  8356.   ListView_InsertItem(Handle, CreateItem(Count, Result));
  8357. end;
  8358.  
  8359. function TListItems.Insert(Index: Integer): TListItem;
  8360. begin
  8361.   Result := Owner.CreateListItem;
  8362.   ListView_InsertItem(Handle, CreateItem(Index, Result));
  8363. end;
  8364.  
  8365. function TListItems.GetCount: Integer;
  8366. begin
  8367.   if Owner.HandleAllocated then Result := ListView_GetItemCount(Handle)
  8368.   else Result := 0;
  8369. end;
  8370.  
  8371. function TListItems.GetHandle: HWND;
  8372. begin
  8373.   Result := Owner.Handle;
  8374. end;
  8375.  
  8376. function TListItems.GetItem(Index: Integer): TListItem;
  8377. var
  8378.   Item: TLVItem;
  8379. begin
  8380.   Result := nil;
  8381.   if Owner.HandleAllocated then
  8382.   begin
  8383.     with Item do
  8384.     begin
  8385.       mask := LVIF_PARAM;
  8386.       iItem := Index;
  8387.       iSubItem := 0;
  8388.     end;
  8389.     if ListView_GetItem(Handle, Item) then Result := TListItem(Item.lParam);
  8390.   end;
  8391. end;
  8392.  
  8393. function TListItems.IndexOf(Value: TListItem): Integer;
  8394. var
  8395.   Info: TLVFindInfo;
  8396. begin
  8397.   with Info do
  8398.   begin
  8399.     flags := LVFI_PARAM;
  8400.     lParam := Integer(Value);
  8401.   end;
  8402.   Result := ListView_FindItem(Handle, -1, Info);
  8403. end;
  8404.  
  8405. procedure TListItems.SetItem(Index: Integer; Value: TListItem);
  8406. begin
  8407.   Item[Index].Assign(Value);
  8408. end;
  8409.  
  8410. procedure TListItems.Clear;
  8411. begin
  8412.   if Owner.HandleAllocated then ListView_DeleteAllItems(Handle);
  8413. end;
  8414.  
  8415. procedure TListItems.BeginUpdate;
  8416. begin
  8417.   if FUpdateCount = 0 then SetUpdateState(True);
  8418.   Inc(FUpdateCount);
  8419. end;
  8420.  
  8421. procedure TListItems.SetUpdateState(Updating: Boolean);
  8422. var
  8423.   i: Integer;
  8424. begin
  8425.   if Updating then
  8426.   begin
  8427.     for i := 0 to Owner.Columns.Count - 1 do
  8428.     begin
  8429.       with Owner.Columns[i] as TListColumn do
  8430.         if WidthType < 0 then
  8431.         begin
  8432.           FPrivateWidth := WidthType;
  8433.           FWidth := Width;
  8434.           DoChange;
  8435.         end;
  8436.     end;
  8437.     SendMessage(Handle, WM_SETREDRAW, 0, 0);
  8438.     if Owner.ColumnsShowing and Owner.ValidHeaderHandle then
  8439.       SendMessage(Owner.FHeaderHandle, WM_SETREDRAW, 0, 0);
  8440.   end
  8441.   else if FUpdateCount = 0 then
  8442.   begin
  8443.     for i := 0 to Owner.Columns.Count - 1 do
  8444.     begin
  8445.       with Owner.Columns[i] as TListColumn do
  8446.         if FPrivateWidth < 0 then
  8447.         begin
  8448.           Width := FPrivateWidth;
  8449.           FPrivateWidth := 0;
  8450.         end;
  8451.     end;
  8452.     FNoRedraw := True;
  8453.     try
  8454.       SendMessage(Handle, WM_SETREDRAW, 1, 0);
  8455.       Owner.Invalidate;
  8456.     finally
  8457.       FNoRedraw := False;
  8458.     end;
  8459.     if Owner.ColumnsShowing and Owner.ValidHeaderHandle then
  8460.       SendMessage(Owner.FHeaderHandle, WM_SETREDRAW, 1, 0);
  8461.   end;
  8462. end;
  8463.  
  8464. procedure TListItems.EndUpdate;
  8465. begin
  8466.   Dec(FUpdateCount);
  8467.   if FUpdateCount = 0 then SetUpdateState(False);
  8468. end;
  8469.  
  8470. procedure TListItems.Assign(Source: TPersistent);
  8471. var
  8472.   Items: TListItems;
  8473.   I: Integer;
  8474. begin
  8475.   if Source is TListItems then
  8476.   begin
  8477.     Clear;
  8478.     Items := TListItems(Source);
  8479.     for I := 0 to Items.Count - 1 do Add.Assign(Items[I]);
  8480.   end
  8481.   else inherited Assign(Source);
  8482. end;
  8483.  
  8484. procedure TListItems.DefineProperties(Filer: TFiler);
  8485.  
  8486.   function WriteItems: Boolean;
  8487.   var
  8488.     I: Integer;
  8489.     Items: TListItems;
  8490.   begin
  8491.     Items := TListItems(Filer.Ancestor);
  8492.     if Items <> nil then
  8493.     begin
  8494.       Result := Items.Count <> Count;
  8495.       if not Result then
  8496.         for I := 0 to Count - 1 do
  8497.         begin
  8498.           Result := not Item[I].IsEqual(Items[I]);
  8499.           if Result then Break;
  8500.         end;
  8501.     end
  8502.     else Result := Count > 0;
  8503.   end;
  8504.  
  8505. begin
  8506.   inherited DefineProperties(Filer);
  8507.   Filer.DefineBinaryProperty('Data', ReadData, WriteData, WriteItems);
  8508. end;
  8509.  
  8510. procedure TListItems.ReadData(Stream: TStream);
  8511. var
  8512.   I, J, Size, L, Len: Integer;
  8513.   ItemHeader: PItemHeader;
  8514.   ItemInfo: PItemInfo;
  8515.   PStr: PShortStr;
  8516. begin
  8517.   Clear;
  8518.   Stream.ReadBuffer(Size, SizeOf(Integer));
  8519.   ItemHeader := AllocMem(Size);
  8520.   try
  8521.     Stream.ReadBuffer(ItemHeader^.Count, Size - SizeOf(Integer));
  8522.     ItemInfo := @ItemHeader^.Items;
  8523.     for I := 0 to ItemHeader^.Count - 1 do
  8524.     begin
  8525.       with Add do
  8526.       begin
  8527.         Caption := ItemInfo^.Caption;
  8528.         ImageIndex := ItemInfo^.ImageIndex;
  8529.         OverlayIndex := ItemInfo^.OverlayIndex;
  8530.         StateIndex := ItemInfo^.StateIndex;
  8531.         Data := ItemInfo^.Data;
  8532.         PStr := @ItemInfo^.Caption;
  8533.         Inc(Integer(PStr), Length(PStr^) + 1);
  8534.         Len := 0;
  8535.         for J := 0 to ItemInfo^.SubItemCount - 1 do
  8536.         begin
  8537.           SubItems.Add(PStr^);
  8538.           L := Length(PStr^);
  8539.           Inc(Len, L + 1);
  8540.           Inc(Integer(PStr), L + 1);
  8541.         end;
  8542.       end;
  8543.       Inc(Integer(ItemInfo), SizeOf(TItemInfo) - 255 +
  8544.         Length(ItemInfo.Caption) + Len);
  8545.     end;
  8546.   finally
  8547.     FreeMem(ItemHeader, Size);
  8548.   end;
  8549. end;
  8550.  
  8551. procedure TListItems.WriteData(Stream: TStream);
  8552. var
  8553.   I, J, Size, L, Len: Integer;
  8554.   ItemHeader: PItemHeader;
  8555.   ItemInfo: PItemInfo;
  8556.   PStr: PShortStr;
  8557.  
  8558.   function GetLength(const S: string): Integer;
  8559.   begin
  8560.     Result := Length(S);
  8561.     if Result > 255 then Result := 255;
  8562.   end;
  8563.  
  8564. begin
  8565.   Size := SizeOf(TItemHeader);
  8566.   for I := 0 to Count - 1 do
  8567.   begin
  8568.     L := GetLength(Item[I].Caption);
  8569.     for J := 0 to Item[I].SubItems.Count - 1 do
  8570.       Inc(L, GetLength(Item[I].SubItems[J]) + 1);
  8571.     Inc(Size, SizeOf(TItemInfo) - 255 + L);
  8572.   end;
  8573.   ItemHeader := AllocMem(Size);
  8574.   try
  8575.     ItemHeader^.Size := Size;
  8576.     ItemHeader^.Count := Count;
  8577.     ItemInfo := @ItemHeader^.Items;
  8578.     for I := 0 to Count - 1 do
  8579.     begin
  8580.       with Item[I] do
  8581.       begin
  8582.         ItemInfo^.Caption := Caption;
  8583.         ItemInfo^.ImageIndex := ImageIndex;
  8584.         ItemInfo^.OverlayIndex := OverlayIndex;
  8585.         ItemInfo^.StateIndex := StateIndex;
  8586.         ItemInfo^.Data := Data;
  8587.         ItemInfo^.SubItemCount := SubItems.Count;
  8588.         PStr := @ItemInfo^.Caption;
  8589.         Inc(Integer(PStr), Length(ItemInfo^.Caption) + 1);
  8590.         Len := 0;
  8591.         for J := 0 to SubItems.Count - 1 do
  8592.         begin
  8593.           PStr^ := SubItems[J];
  8594.           L := Length(PStr^);
  8595.           Inc(Len, L + 1);
  8596.           Inc(Integer(PStr), L + 1);
  8597.         end;
  8598.       end;
  8599.       Inc(Integer(ItemInfo), SizeOf(TItemInfo) - 255 +
  8600.         Length(ItemInfo^.Caption) + Len);
  8601.     end;
  8602.     Stream.WriteBuffer(ItemHeader^, Size);
  8603.   finally
  8604.     FreeMem(ItemHeader, Size);
  8605.   end;
  8606. end;
  8607.  
  8608. procedure TListItems.Delete(Index: Integer);
  8609. begin
  8610.   Item[Index].Delete;
  8611. end;
  8612.  
  8613. function TListItems.CreateItem(Index: Integer;
  8614.   ListItem: TListItem): TLVItem;
  8615. begin
  8616.   with Result do
  8617.   begin
  8618.     mask := LVIF_PARAM or LVIF_IMAGE;
  8619.     iItem := Index;
  8620.     iSubItem := 0;
  8621.     iImage := I_IMAGECALLBACK;
  8622.     lParam := Longint(ListItem);
  8623.   end;
  8624. end;
  8625.  
  8626. { TIconOptions }
  8627.  
  8628. constructor TIconOptions.Create(AOwner: TCustomListView);
  8629. begin
  8630.   inherited Create;
  8631.   if AOwner = nil then raise Exception.Create(sInvalidOwner);
  8632.   FListView := AOwner;
  8633.   Arrangement := iaTop;
  8634.   AutoArrange := False;
  8635.   WrapText := True;
  8636. end;
  8637.  
  8638. procedure TIconOptions.SetArrangement(Value: TIconArrangement);
  8639. begin
  8640.   if Value <> Arrangement then
  8641.   begin;
  8642.     FArrangement := Value;
  8643.     FListView.RecreateWnd;
  8644.     {FListView.SetIconArrangement(Value);}
  8645.   end;
  8646. end;
  8647.  
  8648. procedure TIconOptions.SetAutoArrange(Value: Boolean);
  8649. begin
  8650.   if Value <> AutoArrange then
  8651.   begin
  8652.     FAutoArrange := Value;
  8653.     FListView.RecreateWnd;
  8654.   end;
  8655. end;
  8656.  
  8657. procedure TIconOptions.SetWrapText(Value: Boolean);
  8658. begin
  8659.   if Value <> WrapText then
  8660.   begin
  8661.     FWrapText := Value;
  8662.     FListView.RecreateWnd;
  8663.   end;
  8664. end;
  8665.  
  8666. { TCustomListView }
  8667.  
  8668. function DefaultListViewSort(Item1, Item2: TListItem;
  8669.   lParam: Integer): Integer; stdcall;
  8670. begin
  8671.   with Item1 do
  8672.     if Assigned(ListView.OnCompare) then
  8673.       ListView.OnCompare(ListView, Item1, Item2, lParam, Result)
  8674.     else Result := lstrcmp(PChar(Item1.Caption), PChar(Item2.Caption));
  8675. end;
  8676.  
  8677. constructor TCustomListView.Create(AOwner: TComponent);
  8678. begin
  8679.   inherited Create(AOwner);
  8680.   ControlStyle := ControlStyle - [csCaptureMouse] + [csDisplayDragImage];
  8681.   Width := 250;
  8682.   Height := 150;
  8683.   BorderStyle := bsSingle;
  8684.   ViewStyle := vsIcon;
  8685.   ParentColor := False;
  8686.   TabStop := True;
  8687.   HideSelection := True;
  8688.   ShowColumnHeaders := True;
  8689.   ColumnClick := True;
  8690.   FDragIndex := -1;
  8691.   FListColumns := TListColumns.Create(Self);
  8692.   FListItems := TListItems.Create(Self);
  8693.   FIconOptions := TIconOptions.Create(Self);
  8694.   FDragImage := TImageList.CreateSize(32, 32);
  8695.   FEditInstance := MakeObjectInstance(EditWndProc);
  8696.   FHeaderInstance := MakeObjectInstance(HeaderWndProc);
  8697.   FLargeChangeLink := TChangeLink.Create;
  8698.   FLargeChangeLink.OnChange := ImageListChange;
  8699.   FSmallChangeLink := TChangeLink.Create;
  8700.   FSmallChangeLink.OnChange := ImageListChange;
  8701.   FStateChangeLink := TChangeLink.Create;
  8702.   FStateChangeLink.OnChange := ImageListChange;
  8703. end;
  8704.  
  8705. destructor TCustomListView.Destroy;
  8706. begin
  8707.   DestroyWindowHandle;
  8708.   FDragImage.Free;
  8709.   FListColumns.Free;
  8710.   FListItems.Free;
  8711.   FIconOptions.Free;
  8712.   FMemStream.Free;
  8713.   FreeObjectInstance(FEditInstance);
  8714.   if FHeaderHandle <> 0 then
  8715.     SetWindowLong(FHeaderHandle, GWL_WNDPROC, LongInt(FDefHeaderProc));
  8716.   FreeObjectInstance(FHeaderInstance);
  8717.   FLargeChangeLink.Free;
  8718.   FSmallChangeLink.Free;
  8719.   FStateChangeLink.Free;
  8720.   inherited Destroy;
  8721. end;
  8722.  
  8723. procedure TCustomListView.CreateParams(var Params: TCreateParams);
  8724. const
  8725.   BorderStyles: array[TBorderStyle] of Integer = (0, WS_BORDER);
  8726.   EditStyles: array[Boolean] of Integer = (LVS_EDITLABELS, 0);
  8727.   MultiSelections: array[Boolean] of Integer = (LVS_SINGLESEL, 0);
  8728.   HideSelections: array[Boolean] of Integer = (LVS_SHOWSELALWAYS, 0);
  8729.   Arrangements: array[TIconArrangement] of Integer = (LVS_ALIGNTOP,
  8730.     LVS_ALIGNLEFT);
  8731.   AutoArrange: array[Boolean] of Integer = (0, LVS_AUTOARRANGE);
  8732.   WrapText: array[Boolean] of Integer = (LVS_NOLABELWRAP, 0);
  8733.   ViewStyles: array[TViewStyle] of Integer = (LVS_ICON, LVS_SMALLICON,
  8734.     LVS_LIST, LVS_REPORT);
  8735.   ShowColumns: array[Boolean] of Integer = (LVS_NOCOLUMNHEADER, 0);
  8736.   ColumnClicks: array[Boolean] of Integer = (LVS_NOSORTHEADER, 0);
  8737. begin
  8738.   InitCommonControl(ICC_LISTVIEW_CLASSES);
  8739.   inherited CreateParams(Params);
  8740.   CreateSubClass(Params, WC_LISTVIEW);
  8741.   with Params do
  8742.   begin
  8743.     Style := Style or WS_CLIPCHILDREN or ViewStyles[ViewStyle] or
  8744.       BorderStyles[BorderStyle] or Arrangements[IconOptions.Arrangement] or
  8745.       EditStyles[ReadOnly] or MultiSelections[MultiSelect] or
  8746.       HideSelections[HideSelection] or
  8747.       AutoArrange[IconOptions.AutoArrange] or
  8748.       WrapText[IconOptions.WrapText] or
  8749.       ShowColumns[ShowColumnHeaders] or
  8750.       ColumnClicks[ColumnClick] or
  8751.       LVS_SHAREIMAGELISTS;
  8752.     if Ctl3D and NewStyleControls and (FBorderStyle = bsSingle) then
  8753.     begin
  8754.       Style := Style and not WS_BORDER;
  8755.       ExStyle := Params.ExStyle or WS_EX_CLIENTEDGE;
  8756.     end;
  8757.     WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);
  8758.   end;
  8759. end;
  8760.  
  8761. procedure TCustomListView.CreateWnd;
  8762. begin
  8763.   inherited CreateWnd;
  8764.   SetTextBKColor(Color);
  8765.   SetTextColor(Font.Color);
  8766.   SetAllocBy(AllocBy);
  8767.   if FMemStream <> nil then
  8768.   begin
  8769.     Items.BeginUpdate;
  8770.     try
  8771.       Columns.Clear;
  8772. //      FMemStream.ReadComponentRes(Self);
  8773.       FMemStream.ReadComponent(Self);
  8774.       FMemStream.Destroy;
  8775.       FMemStream := nil;
  8776.       Font := Font;
  8777.     finally
  8778.       Items.EndUpdate;
  8779.     end;
  8780.   end;
  8781.   if (LargeImages <> nil) and LargeImages.HandleAllocated then
  8782.     SetImageList(LargeImages.Handle, LVSIL_NORMAL);
  8783.   if (SmallImages <> nil) and SmallImages.HandleAllocated then
  8784.     SetImageList(SmallImages.Handle, LVSIL_SMALL);
  8785.   if (StateImages <> nil) and StateImages.HandleAllocated then
  8786.     SetImageList(StateImages.Handle, LVSIL_STATE);
  8787.   ResetExStyles;
  8788. end;
  8789.  
  8790. procedure TCustomListView.DestroyWnd;
  8791. begin
  8792.   FMemStream := TMemoryStream.Create;
  8793. //  FMemStream.WriteComponentRes(ClassName, Self);
  8794.   FMemStream.WriteComponent(Self);
  8795.   FMemStream.Position := 0;
  8796.   inherited DestroyWnd;
  8797. end;
  8798.  
  8799. procedure TCustomListView.SetImageList(Value: HImageList; Flags: Integer);
  8800. begin
  8801.   if HandleAllocated then ListView_SetImageList(Handle, Value, Flags);
  8802. end;
  8803.  
  8804. procedure TCustomListView.ImageListChange(Sender: TObject);
  8805. var
  8806.   ImageHandle: HImageList;
  8807. begin
  8808.   if HandleAllocated then
  8809.   begin
  8810.     ImageHandle := TImageList(Sender).Handle;
  8811.     if Sender = LargeImages then SetImageList(ImageHandle, LVSIL_NORMAL)
  8812.     else if Sender = SmallImages then SetImageList(ImageHandle, LVSIL_SMALL)
  8813.     else if Sender = StateImages then SetImageList(ImageHandle, LVSIL_STATE);
  8814.   end;
  8815. end;
  8816.  
  8817. procedure TCustomListView.Notification(AComponent: TComponent;
  8818.   Operation: TOperation);
  8819. begin
  8820.   inherited Notification(AComponent, Operation);
  8821.   if Operation = opRemove then
  8822.   begin
  8823.     if AComponent = LargeImages then LargeImages := nil;
  8824.     if AComponent = SmallImages then SmallImages := nil;
  8825.     if AComponent = StateImages then StateImages := nil;
  8826.   end;
  8827. end;
  8828.  
  8829. procedure TCustomListView.HeaderWndProc(var Message: TMessage);
  8830. begin
  8831.   try
  8832.     with Message do
  8833.     begin
  8834.       case Msg of
  8835.         WM_NCHITTEST:
  8836.           with TWMNCHitTest(Message) do
  8837.             if csDesigning in ComponentState then
  8838.             begin
  8839.               Result := Windows.HTTRANSPARENT;
  8840.               Exit;
  8841.             end;
  8842.         WM_NCDESTROY:
  8843.           begin
  8844.             Result := CallWindowProc(FDefHeaderProc, FHeaderHandle, Msg, WParam, LParam);
  8845.             FHeaderHandle := 0;
  8846.             FDefHeaderProc := nil;
  8847.             Exit;
  8848.           end;
  8849.       end;
  8850.       Result := CallWindowProc(FDefHeaderProc, FHeaderHandle, Msg, WParam, LParam);
  8851.     end;
  8852.   except
  8853.     Application.HandleException(Self);
  8854.   end;
  8855. end;
  8856.  
  8857. procedure TCustomListView.EditWndProc(var Message: TMessage);
  8858. begin
  8859.   try
  8860.     with Message do
  8861.     begin
  8862.       case Msg of
  8863.         WM_KEYDOWN,
  8864.         WM_SYSKEYDOWN: if DoKeyDown(TWMKey(Message)) then Exit;
  8865.         WM_CHAR: if DoKeyPress(TWMKey(Message)) then Exit;
  8866.         WM_KEYUP,
  8867.         WM_SYSKEYUP: if DoKeyUp(TWMKey(Message)) then Exit;
  8868.         CN_KEYDOWN,
  8869.         CN_CHAR, CN_SYSKEYDOWN,
  8870.         CN_SYSCHAR:
  8871.           begin
  8872.             WndProc(Message);
  8873.             Exit;
  8874.           end;
  8875.       end;
  8876.       Result := CallWindowProc(FDefEditProc, FEditHandle, Msg, WParam, LParam);
  8877.     end;
  8878.   except
  8879.     Application.HandleException(Self);
  8880.   end;
  8881. end;
  8882.  
  8883. procedure TCustomListView.UpdateItems(FirstIndex, LastIndex: Integer);
  8884. begin
  8885.   ListView_RedrawItems(Handle, FirstIndex, LastIndex);
  8886. end;
  8887.  
  8888. procedure TCustomListView.ResetExStyles;
  8889. var
  8890.   Styles: DWORD;
  8891. begin
  8892.   Styles := 0;
  8893.   if FCheckboxes then Styles := LVS_EX_CHECKBOXES;
  8894.   if FGridLines then Styles := Styles or LVS_EX_GRIDLINES;
  8895.   if FHotTrack then Styles := Styles or LVS_EX_TRACKSELECT;
  8896.   if FRowSelect then Styles := Styles or LVS_EX_FULLROWSELECT;
  8897.   ListView_SetExtendedListViewStyle(Handle, Styles);
  8898. end;
  8899.  
  8900. procedure TCustomListView.SetCheckboxes(Value: Boolean);
  8901. begin
  8902.   if FCheckboxes <> Value then
  8903.   begin
  8904.     FCheckboxes := Value;
  8905.     ResetExStyles;
  8906.   end;
  8907. end;
  8908.  
  8909. procedure TCustomListView.SetGridLines(Value: Boolean);
  8910. begin
  8911.   if FGridLines <> Value then
  8912.   begin
  8913.     FGridLines := Value;
  8914.     ResetExStyles;
  8915.   end;
  8916. end;
  8917.  
  8918. procedure TCustomListView.SetHotTrack(Value: Boolean);
  8919. begin
  8920.   if FHotTrack <> Value then
  8921.   begin
  8922.     FHotTrack := Value;
  8923.     ResetExStyles;
  8924.   end;
  8925. end;
  8926.  
  8927. procedure TCustomListView.SetRowSelect(Value: Boolean);
  8928. begin
  8929.   if FRowSelect <> Value then
  8930.   begin
  8931.     FRowSelect := Value;
  8932.     ResetExStyles;
  8933.   end;
  8934. end;
  8935.  
  8936. procedure TCustomListView.SetBorderStyle(Value: TBorderStyle);
  8937. begin
  8938.   if BorderStyle <> Value then
  8939.   begin
  8940.     FBorderStyle := Value;
  8941.     RecreateWnd;
  8942.   end;
  8943. end;
  8944.  
  8945. procedure TCustomListView.SetColumnClick(Value: Boolean);
  8946. begin
  8947.   if ColumnClick <> Value then
  8948.   begin
  8949.     FColumnClick := Value;
  8950.     RecreateWnd;
  8951.   end;
  8952. end;
  8953.  
  8954. procedure TCustomListView.SetMultiSelect(Value: Boolean);
  8955. begin
  8956.   if Value <> MultiSelect then
  8957.   begin
  8958.     FMultiSelect := Value;
  8959.     RecreateWnd;
  8960.   end;
  8961. end;
  8962.  
  8963. procedure TCustomListView.SetColumnHeaders(Value: Boolean);
  8964. begin
  8965.   if Value <> ShowColumnHeaders then
  8966.   begin
  8967.     FShowColumnHeaders := Value;
  8968.     RecreateWnd;
  8969.   end;
  8970. end;
  8971.  
  8972. procedure TCustomListView.SetTextColor(Value: TColor);
  8973. begin
  8974.   ListView_SetTextColor(Handle, ColorToRGB(Font.Color));
  8975. end;
  8976.  
  8977. procedure TCustomListView.SetTextBkColor(Value: TColor);
  8978. begin
  8979.   ListView_SetTextBkColor(Handle, ColorToRGB(Color));
  8980. end;
  8981.  
  8982. procedure TCustomListView.SetAllocBy(Value: Integer);
  8983. begin
  8984.   if AllocBy <> Value then
  8985.   begin
  8986.     FAllocBy := Value;
  8987.     if HandleAllocated then ListView_SetItemCount(Handle, Value);
  8988.   end;
  8989. end;
  8990.  
  8991. procedure TCustomListView.CMColorChanged(var Message: TMessage);
  8992. begin
  8993.   inherited;
  8994.   SetTextBkColor(Color);
  8995. end;
  8996.  
  8997. procedure TCustomListView.CMCtl3DChanged(var Message: TMessage);
  8998. begin
  8999.   if FBorderStyle = bsSingle then RecreateWnd;
  9000.   inherited;
  9001. end;
  9002.  
  9003. procedure TCustomListView.WMNotify(var Message: TWMNotify);
  9004. begin
  9005.   inherited;
  9006.   if ValidHeaderHandle then
  9007.     with Message.NMHdr^ do
  9008.       if (hWndFrom = FHeaderHandle) and (code = HDN_BEGINTRACK) then
  9009.         with PHDNotify(Pointer(Message.NMHdr))^, PItem^ do
  9010.           if (Mask and HDI_WIDTH) <> 0 then
  9011.             Column[Item].Width := cxy;
  9012. end;
  9013.  
  9014. function TCustomListView.ColumnsShowing: Boolean;
  9015. begin
  9016.   Result := (ViewStyle = vsReport);
  9017. end;
  9018.  
  9019. function TCustomListView.ValidHeaderHandle: Boolean;
  9020. begin
  9021.   Result := FHeaderHandle <> 0;
  9022. end;
  9023.  
  9024. procedure TCustomListView.CMFontChanged(var Message: TMessage);
  9025. begin
  9026.   inherited;
  9027.   if HandleAllocated then
  9028.   begin
  9029.     SetTextColor(Font.Color);
  9030.     if ValidHeaderHandle then
  9031.       InvalidateRect(FHeaderHandle, nil, True);
  9032.   end;
  9033. end;
  9034.  
  9035. procedure TCustomListView.SetHideSelection(Value: Boolean);
  9036. begin
  9037.   if Value <> HideSelection then
  9038.   begin
  9039.     FHideSelection := Value;
  9040.     RecreateWnd;
  9041.   end;
  9042. end;
  9043.  
  9044. procedure TCustomListView.SetReadOnly(Value: Boolean);
  9045. begin
  9046.   if Value <> ReadOnly then
  9047.   begin
  9048.     FReadOnly := Value;
  9049.     RecreateWnd;
  9050.   end;
  9051. end;
  9052.  
  9053. procedure TCustomListView.SetIconOptions(Value: TIconOptions);
  9054. begin
  9055.   with FIconOptions do
  9056.   begin
  9057.     Arrangement := Value.Arrangement;
  9058.     AutoArrange := Value.AutoArrange;
  9059.     WrapText := Value.WrapText;
  9060.   end;
  9061. end;
  9062.  
  9063. (*
  9064. procedure TCustomListView.SetIconArrangement(Value: TIconArrangement);
  9065. const
  9066.   Arrangements: array[TIconArrangement] of Integer = (LVS_ALIGNTOP,
  9067.     LVS_ALIGNLEFT);
  9068. var
  9069.   Style: Longint;
  9070. begin
  9071.   if HandleAllocated then
  9072.   begin
  9073.     Style := GetWindowLong(Handle, GWL_STYLE);
  9074.     Style := Style and (not LVS_ALIGNMASK);
  9075.     Style := Style or Arrangements[Value];
  9076.     SetWindowLong(Handle, GWL_STYLE, Style);
  9077.   end;
  9078. end;
  9079. *)
  9080.  
  9081. procedure TCustomListView.SetViewStyle(Value: TViewStyle);
  9082. const
  9083.   ViewStyles: array[TViewStyle] of Integer = (LVS_ICON, LVS_SMALLICON,
  9084.     LVS_LIST, LVS_REPORT);
  9085. var
  9086.   Style: Longint;
  9087. begin
  9088.   if Value <> FViewStyle then
  9089.   begin
  9090.     FViewStyle := Value;
  9091.     if HandleAllocated then
  9092.     begin
  9093.       Style := GetWindowLong(Handle, GWL_STYLE);
  9094.       Style := Style and (not LVS_TYPEMASK);
  9095.       Style := Style or ViewStyles[FViewStyle];
  9096.       SetWindowLong(Handle, GWL_STYLE, Style);
  9097.       UpdateColumns;
  9098.       case ViewStyle of
  9099.         vsIcon,
  9100.         vsSmallIcon:
  9101.           if IconOptions.Arrangement = iaTop then
  9102.             Arrange(arAlignTop) else
  9103.             Arrange(arAlignLeft);
  9104.       end;
  9105.     end;
  9106.   end;
  9107. end;
  9108.  
  9109. procedure TCustomListView.WMParentNotify(var Message: TWMParentNotify);
  9110. begin
  9111.   with Message do
  9112.     if (Event = WM_CREATE) and (FHeaderHandle = 0) then
  9113.     begin
  9114.       FHeaderHandle := ChildWnd;
  9115.       FDefHeaderProc := Pointer(GetWindowLong(FHeaderHandle, GWL_WNDPROC));
  9116.       SetWindowLong(FHeaderHandle, GWL_WNDPROC, LongInt(FHeaderInstance));
  9117.     end;
  9118.   inherited;
  9119. end;
  9120.  
  9121. function TCustomListView.GetItemIndex(Value: TListItem): Integer;
  9122. var
  9123.   I: Integer;
  9124. begin
  9125.   Result := -1;
  9126.   for I := 0 to Items.Count - 1 do if Items[I] = Value then Break;
  9127.   if I < Items.Count then Result := I;
  9128. end;
  9129.  
  9130. function TCustomListView.CreateListItem: TListItem;
  9131. begin
  9132.   Result := TListItem.Create(Items);
  9133. end;
  9134.  
  9135. function TCustomListView.GetItem(Value: TLVItem): TListItem;
  9136. begin
  9137.   with Value do
  9138.     if (mask and LVIF_PARAM) <> 0 then Result := TListItem(lParam)
  9139.     else Result := Items[IItem];
  9140. end;
  9141.  
  9142. function TCustomListView.GetSelCount: Integer;
  9143. begin
  9144.   Result := ListView_GetSelectedCount(Handle);
  9145. end;
  9146.  
  9147. procedure TCustomListView.CNNotify(var Message: TWMNotify);
  9148. var
  9149.   Item: TListItem;
  9150.   I: Integer;
  9151. begin
  9152.   with Message.NMHdr^ do
  9153.     case code of
  9154.       LVN_BEGINDRAG:
  9155.         with PNMListView(Pointer(Message.NMHdr))^ do
  9156.           FDragIndex := iItem;
  9157.       LVN_DELETEITEM:
  9158.         with PNMListView(Pointer(Message.NMHdr))^ do
  9159.           Delete(TListItem(lParam));
  9160.       LVN_DELETEALLITEMS:
  9161.         for I := Items.Count - 1 downto 0 do Delete(Items[I]);
  9162.       LVN_GETDISPINFO:
  9163.         begin
  9164.           Item := GetItem(PLVDispInfo(Pointer(Message.NMHdr))^.item);
  9165.           with PLVDispInfo(Pointer(Message.NMHdr))^.item do
  9166.           begin
  9167.             if (mask and LVIF_TEXT) <> 0 then
  9168.               if iSubItem = 0 then
  9169.                 StrPLCopy(pszText, Item.Caption, cchTextMax)
  9170.               else
  9171.                 with Item.SubItems do
  9172.                   if iSubItem <= Count then
  9173.                     StrPLCopy(pszText, Strings[iSubItem - 1], cchTextMax)
  9174.                   else pszText[0] := #0;
  9175.             if (mask and LVIF_IMAGE) <> 0 then iImage := Item.ImageIndex;
  9176.           end;
  9177.         end;
  9178.       LVN_BEGINLABELEDIT:
  9179.         begin
  9180.           Item := GetItem(PLVDispInfo(Pointer(Message.NMHdr))^.item);
  9181.           if not CanEdit(Item) then Message.Result := 1;
  9182.           if Message.Result = 0 then
  9183.           begin
  9184.             FEditHandle := ListView_GetEditControl(Handle);
  9185.             FDefEditProc := Pointer(GetWindowLong(FEditHandle, GWL_WNDPROC));
  9186.             SetWindowLong(FEditHandle, GWL_WNDPROC, LongInt(FEditInstance));
  9187.           end;
  9188.         end;
  9189.       LVN_ENDLABELEDIT:
  9190.         with PLVDispInfo(Pointer(Message.NMHdr))^ do
  9191.           if (item.pszText <> nil) and (item.IItem <> -1) then
  9192.             Edit(item);
  9193.       LVN_COLUMNCLICK:
  9194.         with PNMListView(Pointer(Message.NMHdr))^ do
  9195.           ColClick(Column[iSubItem]);
  9196.       LVN_INSERTITEM:
  9197.         with PNMListView(Pointer(Message.NMHdr))^ do
  9198.           InsertItem(Items[iItem]);
  9199.       LVN_ITEMCHANGING:
  9200.         with PNMListView(Pointer(Message.NMHdr))^ do
  9201.           if not CanChange(Items[iItem], uChanged) then Message.Result := 1;
  9202.       LVN_ITEMCHANGED:
  9203.         with PNMListView(Pointer(Message.NMHdr))^ do
  9204.           Change(Items[iItem], uChanged);
  9205.       NM_CLICK: FClicked := True;
  9206.       NM_RCLICK: FRClicked := True;
  9207.     end;
  9208. end;
  9209.  
  9210. procedure TCustomListView.ColClick(Column: TListColumn);
  9211. begin
  9212.   if Assigned(FOnColumnClick) then FOnColumnClick(Self, Column);
  9213. end;
  9214.  
  9215. procedure TCustomListView.InsertItem(Item: TListItem);
  9216. begin
  9217.   if Assigned(FOnInsert) then FOnInsert(Self, Item);
  9218. end;
  9219.  
  9220. function TCustomListView.CanChange(Item: TListItem; Change: Integer): Boolean;
  9221. var
  9222.   ItemChange: TItemChange;
  9223. begin
  9224.   Result := True;
  9225.   case Change of
  9226.     LVIF_TEXT: ItemChange := ctText;
  9227.     LVIF_IMAGE: ItemChange := ctImage;
  9228.     LVIF_STATE: ItemChange := ctState;
  9229.   else
  9230.     Exit;
  9231.   end;
  9232.   if Assigned(FOnChanging) then FOnChanging(Self, Item, ItemChange, Result);
  9233. end;
  9234.  
  9235. procedure TCustomListView.Change(Item: TListItem; Change: Integer);
  9236. var
  9237.   ItemChange: TItemChange;
  9238. begin
  9239.   case Change of
  9240.     LVIF_TEXT: ItemChange := ctText;
  9241.     LVIF_IMAGE: ItemChange := ctImage;
  9242.     LVIF_STATE: ItemChange := ctState;
  9243.   else
  9244.     Exit;
  9245.   end;
  9246.   if Assigned(FOnChange) then FOnChange(Self, Item, ItemChange);
  9247. end;
  9248.  
  9249. procedure TCustomListView.Delete(Item: TListItem);
  9250. begin
  9251.   if (Item <> nil) and not Item.FProcessedDeleting then
  9252.   begin
  9253.     if Assigned(FOnDeletion) then FOnDeletion(Self, Item);
  9254.     Item.FProcessedDeleting := True;
  9255.     Item.Delete;
  9256.   end;
  9257. end;
  9258.  
  9259. function TCustomListView.CanEdit(Item: TListItem): Boolean;
  9260. begin
  9261.   Result := True;
  9262.   if Assigned(FOnEditing) then FOnEditing(Self, Item, Result);
  9263. end;
  9264.  
  9265. procedure TCustomListView.Edit(const Item: TLVItem);
  9266. var
  9267.   S: string;
  9268.   EditItem: TListItem;
  9269. begin
  9270.   with Item do
  9271.   begin
  9272.     S := pszText;
  9273.     EditItem := GetItem(Item);
  9274.     if Assigned(FOnEdited) then FOnEdited(Self, EditItem, S);
  9275.     if EditItem <> nil then EditItem.Caption := S;
  9276.   end;
  9277. end;
  9278.  
  9279. function TCustomListView.IsEditing: Boolean;
  9280. begin
  9281.   Result := ListView_GetEditControl(Handle) <> 0;
  9282. end;
  9283.  
  9284. function TCustomListView.GetDragImages: TCustomImageList;
  9285. begin
  9286.   if SelCount = 1 then
  9287.     Result := FDragImage else
  9288.     Result := nil;
  9289. end;
  9290.  
  9291. procedure TCustomListView.WndProc(var Message: TMessage);
  9292. begin
  9293.   if not (csDesigning in ComponentState) and ((Message.Msg = WM_LBUTTONDOWN) or
  9294.     (Message.Msg = WM_LBUTTONDBLCLK)) and not Dragging and (DragMode = dmAutomatic) then
  9295.   begin
  9296.     if not IsControlMouseMsg(TWMMouse(Message)) then
  9297.     begin
  9298.       ControlState := ControlState + [csLButtonDown];
  9299.       Dispatch(Message);
  9300.     end;
  9301.   end
  9302.   else if not (((Message.Msg = WM_PAINT) or (Message.Msg = WM_ERASEBKGND)) and
  9303.     Items.FNoRedraw) then
  9304.     inherited WndProc(Message);
  9305. end;
  9306.  
  9307. procedure TCustomListView.DoStartDrag(var DragObject: TDragObject);
  9308. var
  9309.   P, P1: TPoint;
  9310.   ImageHandle: HImageList;
  9311.   DragItem: TListItem;
  9312. begin
  9313.   inherited DoStartDrag(DragObject);
  9314.   FLastDropTarget := nil;
  9315.   GetCursorPos(P);
  9316.   P := ScreenToClient(P);
  9317.   if FDragIndex <> -1 then
  9318.     DragItem := Items[FDragIndex]
  9319.     else DragItem := nil;
  9320.   FDragIndex := -1;
  9321.   if DragItem = nil then
  9322.     with P do DragItem := GetItemAt(X, Y);
  9323.   if DragItem <> nil then
  9324.   begin
  9325.     ImageHandle := ListView_CreateDragImage(Handle, DragItem.Index, P1);
  9326.     if ImageHandle <> 0 then
  9327.       with FDragImage do
  9328.       begin
  9329.         Handle := ImageHandle;
  9330.         with P, DragItem.DisplayRect(drBounds) do
  9331.           SetDragImage(0, X - Left , Y - Top);
  9332.       end;
  9333.   end;
  9334. end;
  9335.  
  9336. procedure TCustomListView.DoEndDrag(Target: TObject; X, Y: Integer);
  9337. begin
  9338.   inherited DoEndDrag(Target, X, Y);
  9339.   FLastDropTarget := nil;
  9340. end;
  9341.  
  9342. procedure TCustomListView.CMDrag(var Message: TCMDrag);
  9343. begin
  9344.   inherited;
  9345.   if Message.Result <> 0 then
  9346.     with Message, DragRec^ do
  9347.       case DragMessage of
  9348.         dmDragMove: with ScreenToClient(Pos) do DoDragOver(Source, X, Y);
  9349.         dmDragLeave:
  9350.           begin
  9351.             TDragObject(Source).HideDragImage;
  9352.             FLastDropTarget := DropTarget;
  9353.             DropTarget := nil;
  9354.             Update;
  9355.             TDragObject(Source).ShowDragImage;
  9356.           end;
  9357.         dmDragDrop: FLastDropTarget := nil;
  9358.       end;
  9359. end;
  9360.  
  9361. procedure TCustomListView.DoDragOver(Source: TDragObject; X, Y: Integer);
  9362. var
  9363.   Item: TListItem;
  9364.   Target: TListItem;
  9365. begin
  9366.   Item := GetItemAt(X, Y);
  9367.   if Item <> nil then
  9368.   begin
  9369.     Target := DropTarget;
  9370.     if (Item <> Target) or (Item = FLastDropTarget) then
  9371.     begin
  9372.       FLastDropTarget := nil;
  9373.       TDragObject(Source).HideDragImage;
  9374.       if Target <> nil then
  9375.         Target.DropTarget := False;
  9376.       Item.DropTarget := True;
  9377.       Update;
  9378.       TDragObject(Source).ShowDragImage;
  9379.     end;
  9380.   end;
  9381. end;
  9382.  
  9383. procedure TCustomListView.SetItems(Value: TListItems);
  9384. begin
  9385.   FListItems.Assign(Value);
  9386. end;
  9387.  
  9388. procedure TCustomListView.SetListColumns(Value: TListColumns);
  9389. begin
  9390.   FListColumns.Assign(Value);
  9391. end;
  9392.  
  9393. function TCustomListView.CustomSort(SortProc: TLVCompare; lParam: Longint): Boolean;
  9394. begin
  9395.   Result := False;
  9396.   if HandleAllocated then
  9397.   begin
  9398.     if not Assigned(SortProc) then SortProc := @DefaultListViewSort;
  9399.     Result := ListView_SortItems(Handle, SortProc, lParam);
  9400.   end;
  9401. end;
  9402.  
  9403. function TCustomListView.AlphaSort: Boolean;
  9404. begin
  9405.   if HandleAllocated then
  9406.     Result := ListView_SortItems(Handle, @DefaultListViewSort, 0)
  9407.   else Result := False;
  9408. end;
  9409.  
  9410. procedure TCustomListView.SetSortType(Value: TSortType);
  9411. begin
  9412.   if SortType <> Value then
  9413.   begin
  9414.     FSortType := Value;
  9415.     if ((SortType in [stData, stBoth]) and Assigned(OnCompare)) or
  9416.       (SortType in [stText, stBoth]) then
  9417.       AlphaSort;
  9418.   end;
  9419. end;
  9420.  
  9421. function TCustomListView.GetVisibleRowCount: Integer;
  9422. begin
  9423.   if ViewStyle in [vsReport, vsList] then
  9424.     Result := ListView_GetCountPerPage(Handle)
  9425.   else Result := 0;
  9426. end;
  9427.  
  9428. function TCustomListView.GetViewOrigin: TPoint;
  9429. begin
  9430.   ListView_GetOrigin(Handle, Result);
  9431. end;
  9432.  
  9433. function TCustomListView.GetTopItem: TListItem;
  9434. var
  9435.   Index: Integer;
  9436. begin
  9437.   Result := nil;
  9438.   if not (ViewStyle in [vsSmallIcon, vsIcon]) then
  9439.   begin
  9440.     Index := ListView_GetTopIndex(Handle);
  9441.     if Index <> -1 then Result := Items[Index];
  9442.   end;
  9443. end;
  9444.  
  9445. function TCustomListView.GetBoundingRect: TRect;
  9446. begin
  9447.   ListView_GetViewRect(Handle, Result);
  9448. end;
  9449.  
  9450. procedure TCustomListView.Scroll(DX, DY: Integer);
  9451. begin
  9452.   ListView_Scroll(Handle, DX, DY);
  9453. end;
  9454.  
  9455. procedure TCustomListView.SetLargeImages(Value: TImageList);
  9456. begin
  9457.   if LargeImages <> nil then
  9458.     LargeImages.UnRegisterChanges(FLargeChangeLink);
  9459.   FLargeImages := Value;
  9460.   if LargeImages <> nil then
  9461.   begin
  9462.     LargeImages.RegisterChanges(FLargeChangeLink);
  9463.     SetImageList(LargeImages.Handle, LVSIL_NORMAL)
  9464.   end
  9465.   else SetImageList(0, LVSIL_NORMAL);
  9466. end;
  9467.  
  9468. procedure TCustomListView.SetSmallImages(Value: TImageList);
  9469. begin
  9470.   if SmallImages <> nil then
  9471.     SmallImages.UnRegisterChanges(FSmallChangeLink);
  9472.   FSmallImages := Value;
  9473.   if SmallImages <> nil then
  9474.   begin
  9475.     SmallImages.RegisterChanges(FSmallChangeLink);
  9476.     SetImageList(SmallImages.Handle, LVSIL_SMALL)
  9477.   end
  9478.   else SetImageList(0, LVSIL_SMALL);
  9479. end;
  9480.  
  9481. procedure TCustomListView.SetStateImages(Value: TImageList);
  9482. begin
  9483.   if StateImages <> nil then
  9484.     StateImages.UnRegisterChanges(FStateChangeLink);
  9485.   FStateImages := Value;
  9486.   if StateImages <> nil then
  9487.   begin
  9488.     StateImages.RegisterChanges(FStateChangeLink);
  9489.     SetImageList(StateImages.Handle, LVSIL_STATE)
  9490.   end
  9491.   else SetImageList(0, LVSIL_STATE);
  9492. end;
  9493.  
  9494. function TCustomListView.GetColumnFromIndex(Index: Integer): TListColumn;
  9495. begin
  9496.   Result := FListColumns[Index];
  9497. end;
  9498.  
  9499. function TCustomListView.FindCaption(StartIndex: Integer; Value: string;
  9500.   Partial, Inclusive, Wrap: Boolean): TListItem;
  9501. const
  9502.   FullString: array[Boolean] of Integer = (0, LVFI_PARTIAL);
  9503.   Wraps: array[Boolean] of Integer = (0, LVFI_WRAP);
  9504. var
  9505.   Info: TLVFindInfo;
  9506.   Index: Integer;
  9507. begin
  9508.   with Info do
  9509.   begin
  9510.     flags := LVFI_STRING or FullString[Partial] or Wraps[Wrap];
  9511.     psz := PChar(Value);
  9512.   end;
  9513.   if Inclusive then Dec(StartIndex);
  9514.   Index := ListView_FindItem(Handle, StartIndex, Info);
  9515.   if Index <> -1 then Result := Items[Index]
  9516.   else Result := nil;
  9517. end;
  9518.  
  9519. function TCustomListView.FindData(StartIndex: Integer; Value: Pointer;
  9520.   Inclusive, Wrap: Boolean): TListItem;
  9521. var
  9522.   I: Integer;
  9523. begin
  9524.   Result := nil;
  9525.   if Inclusive then Dec(StartIndex);
  9526.   for I := StartIndex + 1 to Items.Count - 1 do
  9527.     if Items[I].Data = Value then Break;
  9528.   if I <= Items.Count - 1 then Result := Items[I]
  9529.   else if Wrap then
  9530.   begin
  9531.     if Inclusive then Inc(StartIndex);
  9532.     for I := 0 to StartIndex - 1 do
  9533.       if Items[I].Data = Value then Break;
  9534.     if I <= StartIndex then Result := Items[I];
  9535.   end;
  9536. end;
  9537.  
  9538. function TCustomListView.GetSelection: TListItem;
  9539. begin
  9540.   Result := GetNextItem(nil, sdAll, [isSelected]);
  9541. end;
  9542.  
  9543. procedure TCustomListView.SetSelection(Value: TListItem);
  9544. var
  9545.   I: Integer;
  9546. begin
  9547.   if Value <> nil then Value.Selected := True
  9548.   else begin
  9549.     Value := Selected;
  9550.     for I := 0 to SelCount - 1 do
  9551.       if Value <> nil then
  9552.       begin
  9553.         Value.Selected := False;
  9554.         Value := GetNextItem(Value, sdAll, [isSelected]);
  9555.       end;
  9556.   end;
  9557. end;
  9558.  
  9559. function TCustomListView.GetDropTarget: TListItem;
  9560. begin
  9561.   Result := GetNextItem(nil, sdAll, [isDropHilited]);
  9562.   if Result = nil then Result := FLastDropTarget;
  9563. end;
  9564.  
  9565. procedure TCustomListView.SetDropTarget(Value: TListItem);
  9566. begin
  9567.   if HandleAllocated then
  9568.     if Value <> nil then Value.DropTarget := True
  9569.     else begin
  9570.       Value := DropTarget;
  9571.       if Value <> nil then Value.DropTarget := False;
  9572.     end;
  9573. end;
  9574.  
  9575. function TCustomListView.GetFocused: TListItem;
  9576. begin
  9577.   Result := GetNextItem(nil, sdAll, [isFocused]);
  9578. end;
  9579.  
  9580. procedure TCustomListView.SetFocused(Value: TListItem);
  9581. begin
  9582.   if HandleAllocated then
  9583.     if Value <> nil then Value.Focused := True
  9584.     else begin
  9585.       Value := ItemFocused;
  9586.       if Value <> nil then Value.Focused := False;
  9587.     end;
  9588. end;
  9589.  
  9590. function TCustomListView.GetNextItem(StartItem: TListItem;
  9591.   Direction: TSearchDirection; States: TItemStates): TListItem;
  9592. var
  9593.   Flags, Index: Integer;
  9594. begin
  9595.   Result := nil;
  9596.   if HandleAllocated then
  9597.   begin
  9598.     Flags := 0;
  9599.     case Direction of
  9600.       sdAbove: Flags := LVNI_ABOVE;
  9601.       sdBelow: Flags := LVNI_BELOW;
  9602.       sdLeft: Flags := LVNI_TOLEFT;
  9603.       sdRight: Flags := LVNI_TORIGHT;
  9604.       sdAll: Flags := LVNI_ALL;
  9605.     end;
  9606.     if StartItem <> nil then Index := StartItem.Index
  9607.     else Index := -1;
  9608.     if isCut in States then Flags := Flags or LVNI_CUT;
  9609.     if isDropHilited in States then Flags := Flags or LVNI_DROPHILITED;
  9610.     if isFocused in States then Flags := Flags or LVNI_FOCUSED;
  9611.     if isSelected in States then Flags := Flags or LVNI_SELECTED;
  9612.     Index := ListView_GetNextItem(Handle, Index, Flags);
  9613.     if Index <> -1 then Result := Items[Index];
  9614.   end;
  9615. end;
  9616.  
  9617. function TCustomListView.GetNearestItem(Point: TPoint;
  9618.   Direction: TSearchDirection): TListItem;
  9619. const
  9620.   Directions: array[TSearchDirection] of Integer = (VK_LEFT, VK_RIGHT,
  9621.     VK_UP, VK_DOWN, 0);
  9622. var
  9623.   Info: TLVFindInfo;
  9624.   Index: Integer;
  9625. begin
  9626.   with Info do
  9627.   begin
  9628.     flags := LVFI_NEARESTXY;
  9629.     pt := Point;
  9630.     vkDirection := Directions[Direction];
  9631.   end;
  9632.   Index := ListView_FindItem(Handle, -1, Info);
  9633.   if Index <> -1 then Result := Items[Index]
  9634.   else Result := nil;
  9635. end;
  9636.  
  9637. function TCustomListView.GetItemAt(X, Y: Integer): TListItem;
  9638. var
  9639.   Info: TLVHitTestInfo;
  9640. var
  9641.   Index: Integer;
  9642. begin
  9643.   Result := nil;
  9644.   if HandleAllocated then
  9645.   begin
  9646.     Info.pt := Point(X, Y);
  9647.     Index := ListView_HitTest(Handle, Info);
  9648.     if Index <> -1 then Result := Items[Index];
  9649.   end;
  9650. end;
  9651.  
  9652. procedure TCustomListView.Arrange(Code: TListArrangement);
  9653. const
  9654.   Codes: array[TListArrangement] of Longint = (LVA_ALIGNBOTTOM, LVA_ALIGNLEFT,
  9655.     LVA_ALIGNRIGHT, LVA_ALIGNTOP, LVA_DEFAULT, LVA_SNAPTOGRID);
  9656. begin
  9657.   ListView_Arrange(Handle, Codes[Code]);
  9658. end;
  9659.  
  9660. function TCustomListView.StringWidth(S: string): Integer;
  9661. begin
  9662.   Result := ListView_GetStringWidth(Handle, PChar(S));
  9663. end;
  9664.  
  9665. procedure TCustomListView.UpdateColumns;
  9666. var
  9667.   I: Integer;
  9668. begin
  9669.   if HandleAllocated then
  9670.     for I := 0 to Columns.Count - 1 do UpdateColumn(I);
  9671. end;
  9672.  
  9673. procedure TCustomListView.UpdateColumn(Index: Integer);
  9674. var
  9675.   Column: TLVColumn;
  9676. begin
  9677.   if HandleAllocated then
  9678.     with Column, Columns.Items[Index] do
  9679.     begin
  9680.       mask := LVCF_TEXT or LVCF_FMT;
  9681.       pszText := PChar(Caption);
  9682.       if Index <> 0 then
  9683.         case Alignment of
  9684.           taLeftJustify: fmt := LVCFMT_LEFT;
  9685.           taCenter: fmt := LVCFMT_CENTER;
  9686.           taRightJustify: fmt := LVCFMT_RIGHT;
  9687.         end
  9688.       else fmt := LVCFMT_LEFT;
  9689.       if WidthType > ColumnTextWidth then
  9690.       begin
  9691.         mask := mask or LVCF_WIDTH;
  9692.         cx := FWidth;
  9693.         ListView_SetColumn(Handle, Index, Column);
  9694.       end
  9695.       else begin
  9696.         ListView_SetColumn(Handle, Index, Column);
  9697.         if ViewStyle = vsList then
  9698.           ListView_SetColumnWidth(Handle, -1, WidthType)
  9699.         else if ViewStyle = vsReport then
  9700.           ListView_SetColumnWidth(Handle, Index, WidthType);
  9701.       end;
  9702.     end;
  9703. end;
  9704.  
  9705. procedure TCustomListView.WMRButtonDown(var Message: TWMRButtonDown);
  9706. var
  9707.   MousePos: TPoint;
  9708. begin
  9709.   FRClicked := False;
  9710.   inherited;
  9711.   if FRClicked then
  9712.   begin
  9713.     GetCursorPos(MousePos);
  9714.     with PointToSmallPoint(ScreenToClient(MousePos)) do
  9715.       Perform(WM_RBUTTONUP, 0, MakeLong(X, Y));
  9716.   end;
  9717. end;
  9718.  
  9719. procedure TCustomListView.WMLButtonDown(var Message: TWMLButtonDown);
  9720. var
  9721.   Item: TListItem;
  9722.   MousePos: TPoint;
  9723.   ShiftState: TShiftState;
  9724. begin
  9725.   SetFocus;
  9726.   ShiftState := KeysToShiftState(Message.Keys);
  9727.   FClicked := False;
  9728.   FDragIndex := -1;
  9729.   inherited;
  9730.   if (DragMode = dmAutomatic) and MultiSelect then
  9731.   begin
  9732.     if not (ssShift in ShiftState) and not (ssCtrl in ShiftState) then
  9733.     begin
  9734.       if not FClicked then
  9735.       begin
  9736.         Item := GetItemAt(Message.XPos, Message.YPos);
  9737.         if (Item <> nil) and Item.Selected then
  9738.         begin
  9739.           BeginDrag(False);
  9740.           Exit;
  9741.         end;
  9742.       end;
  9743.     end;
  9744.   end;
  9745.   if FClicked then
  9746.   begin
  9747.     GetCursorPos(MousePos);
  9748.     with PointToSmallPoint(ScreenToClient(MousePos)) do
  9749.       if not Dragging then Perform(WM_LBUTTONUP, 0, MakeLong(X, Y))
  9750.       else SendMessage(GetCapture, WM_LBUTTONUP, 0, MakeLong(X, Y));
  9751.   end
  9752.   else if (DragMode = dmAutomatic) and not (MultiSelect and
  9753.     ((ssShift in ShiftState) or (ssCtrl in ShiftState))) then
  9754.   begin
  9755.     Item := GetItemAt(Message.XPos, Message.YPos);
  9756.     if (Item <> nil) and Item.Selected then
  9757.       BeginDrag(False);
  9758.   end;
  9759. end;
  9760.  
  9761. function TCustomListView.GetSearchString: string;
  9762. var
  9763.   Buffer: array[0..1023] of char;
  9764. begin
  9765.   Result := '';
  9766.   if HandleAllocated and ListView_GetISearchString(Handle, Buffer) then
  9767.     Result := Buffer;
  9768. end;
  9769.  
  9770. { TAnimate }
  9771.  
  9772. constructor TAnimate.Create(AOwner: TComponent);
  9773. begin
  9774.   inherited Create(AOwner);
  9775.   ControlStyle := [];
  9776.   Width := 100;
  9777.   Height := 80;
  9778.   FAutoSize := True;
  9779.   FCenter := True;
  9780.   FRepetitions := -1;
  9781.   FStartFrame := 0;
  9782.   FStopFrame := Word(-1);
  9783.   FTransparent := True;
  9784. end;
  9785.  
  9786. procedure TAnimate.CreateParams(var Params: TCreateParams);
  9787. const
  9788.   ShellModuleName = 'shell32.dll';
  9789.   CenterStyles: array[Boolean] of Integer = (0, ACS_CENTER);
  9790.   TimerStyles: array[Boolean] of Integer = (0, ACS_TIMER);
  9791.   TransparentStyles: array[Boolean] of Integer = (0, ACS_TRANSPARENT);
  9792. var
  9793.   OldError: Longint;
  9794. begin
  9795.   if (FCommonAVI <> caNone) then
  9796.   begin
  9797.     OldError := SetErrorMode(SEM_NOOPENFILEERRORBOX);
  9798.     ShellModule := GetModuleHandle(ShellModuleName);
  9799.     if ShellModule < HINSTANCE_ERROR then
  9800.       ShellModule := LoadLibrary(ShellModuleName);
  9801.     if ShellModule < HINSTANCE_ERROR then ShellModule := 0;
  9802.     SetErrorMode(OldError);
  9803.   end;
  9804.   InitCommonControl(ICC_ANIMATE_CLASS);
  9805.   inherited CreateParams(Params);
  9806.   { The ANIMATE common control requires that it be created in the same
  9807.     instance address space as the AVI resource. }
  9808.   Params.WindowClass.hInstance := GetActualResHandle;
  9809.   CreateSubClass(Params, ANIMATE_CLASS);
  9810.   with Params do
  9811.   begin
  9812.     Style := Style or CenterStyles[FCenter] or TimerStyles[FTimers] or
  9813.       TransparentStyles[FTransparent];
  9814.     WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);
  9815.     { Make sure window class is unique per instance. }
  9816.     StrFmt(WinClassName, 'TAnimate.%.8X:%.8X', [HInstance, GetCurrentThreadID]);
  9817.   end;
  9818. end;
  9819.  
  9820. procedure TAnimate.CreateHandle;
  9821. begin
  9822.   inherited CreateHandle;
  9823.   { Restore active state }
  9824.   if not (csLoading in ComponentState) then
  9825.   begin
  9826.     Open := True;
  9827.     if FActive then
  9828.     begin
  9829.       FActive := False;
  9830.       SetActive(True);
  9831.     end;
  9832.   end;
  9833. end;
  9834.  
  9835. procedure TAnimate.WMPaint(var Message: TWMPaint);
  9836. begin
  9837.   inherited;
  9838.   if csDesigning in ComponentState then
  9839.     with TControlCanvas.Create do
  9840.     try
  9841.       Control := Self;
  9842.       Pen.Style := psDash;
  9843.       Brush.Style := bsClear;
  9844.       Rectangle(0, 0, ClientWidth, ClientHeight);
  9845.     finally
  9846.       Free;
  9847.     end;
  9848. end;
  9849.  
  9850. procedure TAnimate.WMSize(var Message: TMessage);
  9851. begin
  9852.   inherited;
  9853.   if not (csLoading in ComponentState) then Resize;
  9854. end;
  9855.  
  9856. procedure TAnimate.CMColorChanged(var Message: TMessage);
  9857. begin
  9858.   inherited;
  9859.   if not (csLoading in ComponentState) then RecreateWnd;
  9860. end;
  9861.  
  9862. procedure TAnimate.CMRecreateWnd(var Message: TMessage);
  9863. begin
  9864.   FRecreateNeeded := False;
  9865.   FOpen := False;
  9866.   inherited;
  9867. end;
  9868.  
  9869. procedure TAnimate.CNCommand(var Message: TWMCommand);
  9870. begin
  9871.   inherited;
  9872.   case Message.NotifyCode of
  9873.     ACN_START: DoStart;
  9874.     ACN_STOP: DoStop;
  9875.   end;
  9876. end;
  9877.  
  9878. procedure TAnimate.DoOpen;
  9879. begin
  9880.   if Assigned(FOnOpen) then FOnOpen(Self);
  9881. end;
  9882.  
  9883. procedure TAnimate.DoClose;
  9884. begin
  9885.   if Assigned(FOnClose) then FOnClose(Self);
  9886. end;
  9887.  
  9888. procedure TAnimate.DoStart;
  9889. begin
  9890.   if Assigned(FOnStart) then FOnStart(Self);
  9891. end;
  9892.  
  9893. procedure TAnimate.DoStop;
  9894. begin
  9895.   if Assigned(FOnStop) then FOnStop(Self);
  9896.   SetActive(False);
  9897. end;
  9898.  
  9899. procedure TAnimate.Loaded;
  9900. begin
  9901.   inherited Loaded;
  9902.   if FStreamedActive then SetActive(True);
  9903. end;
  9904.  
  9905. function TAnimate.GetActualResHandle: Integer;
  9906. begin
  9907.   if FCommonAVI <> caNone then Result := ShellModule
  9908.   else if FResHandle <> 0 then Result := FResHandle
  9909.   else Result := MainInstance;
  9910. end;
  9911.  
  9912. function TAnimate.GetActualResId: Integer;
  9913. const
  9914.   CommonAVIId: array[TCommonAVI] of Integer = (0, 150, 151, 152, 160, 161, 162,
  9915.     163, 164);
  9916. begin
  9917.   if FCommonAVI <> caNone then Result := CommonAVIId[FCommonAVI]
  9918.   else if FFileName <> '' then Result := Integer(FFileName)
  9919.   else if FResName <> '' then Result := Integer(FResName)
  9920.   else Result := FResId;
  9921. end;
  9922.  
  9923. procedure TAnimate.GetFrameInfo;
  9924.  
  9925.   function CreateResStream: TStream;
  9926.   const
  9927.     ResType = 'AVI';
  9928.   var
  9929.     Instance: THandle;
  9930.   begin
  9931.     { AVI is from a file }
  9932.     if FFileName <> '' then
  9933.       Result := TFileStream.Create(FFileName, fmShareDenyNone)
  9934.     else
  9935.     begin
  9936.       { AVI is from a resource }
  9937.       Instance := GetActualResHandle;
  9938.       if FResName <> '' then
  9939.         Result := TResourceStream.Create(Instance, FResName, ResType)
  9940.       else Result := TResourceStream.CreateFromID(Instance, GetActualResId, ResType);
  9941.     end;
  9942.   end;
  9943.  
  9944. const
  9945.   CountOffset = 48;
  9946.   WidthOffset = 64;
  9947.   HeightOffset = 68;
  9948. begin
  9949.   with CreateResStream do
  9950.   try
  9951.     if Seek(CountOffset, soFromBeginning) = CountOffset then
  9952.       ReadBuffer(FFrameCount, SizeOf(FFrameCount));
  9953.     if Seek(WidthOffset, soFromBeginning) = WidthOffset then
  9954.       ReadBuffer(FFrameWidth, SizeOf(FFrameWidth));
  9955.     if Seek(HeightOffset, soFromBeginning) = HeightOffset then
  9956.       ReadBuffer(FFrameHeight, SizeOf(FFrameHeight));
  9957.   finally
  9958.     Free;
  9959.   end;
  9960. end;
  9961.  
  9962. procedure TAnimate.SetActive(Value: Boolean);
  9963. begin
  9964.   if (csReading in ComponentState) then
  9965.   begin
  9966.     if Value then FStreamedActive := True;
  9967.   end
  9968.   else
  9969.   begin
  9970.     if FActive <> Value then
  9971.     begin
  9972.       if Value then
  9973.         Play(FStartFrame, FStopFrame, FRepetitions)
  9974.       else
  9975.         Stop;
  9976.     end;
  9977.   end;
  9978. end;
  9979.  
  9980. procedure TAnimate.SetAutoSize(Value: Boolean);
  9981. begin
  9982.   if FAutoSize <> Value then
  9983.   begin
  9984.     FAutoSize := Value;
  9985.     { Update current size }
  9986.     if not (csLoading in ComponentState) then Perform(WM_SIZE, 0, 0);
  9987.   end;
  9988. end;
  9989.  
  9990. procedure TAnimate.SetCenter(Value: Boolean);
  9991. begin
  9992.   if FCenter <> Value then
  9993.   begin
  9994.     FCenter := Value;
  9995.     RecreateWnd;
  9996.   end;
  9997. end;
  9998.  
  9999. procedure TAnimate.SetCommonAVI(Value: TCommonAVI);
  10000. begin
  10001.   if FCommonAVI <> Value then
  10002.   begin
  10003.     FRecreateNeeded := (FCommonAVI = caNone);
  10004.     FCommonAVI := Value;
  10005.     FFileName := '';
  10006.     FResHandle := 0;
  10007.     FResName := '';
  10008.     FResId := 0;
  10009.     if Value = caNone then SetOpen(False) else Reset;
  10010.   end;
  10011. end;
  10012.  
  10013. procedure TAnimate.SetFileName(Value: string);
  10014. begin
  10015.   if FFileName <> Value then
  10016.   begin
  10017.     FFileName := Value;
  10018.     FCommonAVI := caNone;
  10019.     FResHandle := 0;
  10020.     FResName := '';
  10021.     FResId := 0;
  10022.     if FFileName = '' then SetOpen(False) else Reset;
  10023.   end;
  10024. end;
  10025.  
  10026. procedure TAnimate.SetOpen(Value: Boolean);
  10027. begin
  10028.   if (FOpen <> Value) then
  10029.     if Value then
  10030.     begin
  10031.       FOpen := InternalOpen;
  10032.       Resize;
  10033.     end
  10034.     else FOpen := InternalClose;
  10035. end;
  10036.  
  10037. procedure TAnimate.SetRepetitions(Value: Integer);
  10038. begin
  10039.   if FRepetitions <> Value then
  10040.   begin
  10041.     FRepetitions := Value;
  10042.     Stop;
  10043.   end;
  10044. end;
  10045.  
  10046. procedure TAnimate.SetResHandle(Value: THandle);
  10047. begin
  10048.   if FResHandle <> Value then
  10049.   begin
  10050.     FResHandle := Value;
  10051.     FRecreateNeeded := True;
  10052.     FCommonAVI := caNone;
  10053.     FFileName := '';
  10054.     if FResHandle = 0 then SetOpen(False) else Reset;
  10055.   end;
  10056. end;
  10057.  
  10058. procedure TAnimate.SetResId(Value: Integer);
  10059. begin
  10060.   if FResId <> Value then
  10061.   begin
  10062.     FResId := Value;
  10063.     FRecreateNeeded := (FCommonAVI <> caNone) or (FFileName <> '');
  10064.     FCommonAVI := caNone;
  10065.     FFileName := '';
  10066.     FResName := '';
  10067.     if Value = 0 then SetOpen(False) else Reset;
  10068.   end;
  10069. end;
  10070.  
  10071. procedure TAnimate.SetResName(Value: string);
  10072. begin
  10073.   if FResName <> Value then
  10074.   begin
  10075.     FResName := Value;
  10076.     FRecreateNeeded := (FCommonAVI <> caNone) or (FFileName <> '');
  10077.     FCommonAVI := caNone;
  10078.     FFileName := '';
  10079.     FResId := 0;
  10080.     if Value = '' then SetOpen(False) else Reset;
  10081.   end;
  10082. end;
  10083.  
  10084. procedure TAnimate.SetStartFrame(Value: Word);
  10085. begin
  10086.   if FStartFrame <> Value then
  10087.   begin
  10088.     FStartFrame := Value;
  10089.     Stop;
  10090.     if not (csLoading in ComponentState) then Seek(Value);
  10091.   end;
  10092. end;
  10093.  
  10094. procedure TAnimate.SetStopFrame(Value: Word);
  10095. begin
  10096.   if FStopFrame <> Value then
  10097.   begin
  10098.     FStopFrame := Value;
  10099.     Stop;
  10100.   end;
  10101. end;
  10102.  
  10103. procedure TAnimate.SetTimers(Value: Boolean);
  10104. begin
  10105.   if FTimers <> Value then
  10106.   begin
  10107.     FTimers := Value;
  10108.     RecreateWnd;
  10109.   end;
  10110. end;
  10111.  
  10112. procedure TAnimate.SetTransparent(Value: Boolean);
  10113. begin
  10114.   if FTransparent <> Value then
  10115.   begin
  10116.     FTransparent := Value;
  10117.     RecreateWnd;
  10118.   end;
  10119. end;
  10120.  
  10121. procedure TAnimate.AlignControls(AControl: TControl; var Rect: TRect);
  10122. begin
  10123.   if not (csReadingState in ControlState) then Resize;
  10124.   inherited AlignControls(AControl, Rect);
  10125. end;
  10126.  
  10127. procedure TAnimate.CheckOpen;
  10128. begin
  10129.   Open := True;
  10130.   if not Open then raise Exception.Create(SCannotOpenAVI);
  10131. end;
  10132.  
  10133. function TAnimate.InternalOpen: Boolean;
  10134. var
  10135.   R: TRect;
  10136. begin
  10137.   if FRecreateNeeded then RecreateWnd;
  10138.   HandleNeeded;
  10139.   { Preserve dimensions to prevent auto sizing }
  10140.   if not Center then R := BoundsRect;
  10141.   Result := Perform(ACM_OPEN, 0, GetActualResId) <> 0;
  10142.   { Restore dimensions in case control was resized }
  10143.   if not Center then BoundsRect := R;
  10144.   if Result then
  10145.   begin
  10146.     GetFrameInfo;
  10147.     FStartFrame := 0;
  10148.     FStopFrame := FFrameCount - 1;
  10149.     DoOpen;
  10150.   end;
  10151. end;
  10152.  
  10153. function TAnimate.InternalClose: Boolean;
  10154. begin
  10155.   Result := Perform(ACM_OPEN, 0, 0) <> 0;
  10156.   DoClose;
  10157.   Invalidate;
  10158. end;
  10159.  
  10160. procedure TAnimate.Resize;
  10161. var
  10162.   NewWidth, NewHeight: Integer;
  10163. begin
  10164.   if FAutoSize and (Open or not (csDesigning in ComponentState)) then
  10165.   begin
  10166.     NewWidth := Width;
  10167.     NewHeight := Height;
  10168.     case Align of
  10169.       alNone:
  10170.         begin
  10171.           NewWidth := FrameWidth;
  10172.           NewHeight := FrameHeight;
  10173.         end;
  10174.       alLeft, alRight: NewWidth := FrameWidth;
  10175.       alTop, alBottom: NewHeight := FrameHeight;
  10176.     end;
  10177.     SetBounds(Left, Top, NewWidth, NewHeight);
  10178.   end;
  10179. end;
  10180.  
  10181. procedure TAnimate.Play(FromFrame, ToFrame: Word; Count: Integer);
  10182. begin
  10183.   CheckOpen;
  10184.   FActive := True;
  10185.   if Perform(ACM_PLAY, Count, MakeLong(Word(FromFrame), Word(ToFrame))) <> 1 then
  10186.     FActive := False;
  10187. end;
  10188.  
  10189. procedure TAnimate.Reset;
  10190. begin
  10191.   SetOpen(False);
  10192.   Seek(0);
  10193. end;
  10194.  
  10195. procedure TAnimate.Seek(Frame: Integer);
  10196. begin
  10197.   { This works around the control's inablity to seek to the first frame }
  10198.   CheckOpen;
  10199.   Perform(ACM_PLAY, 1, MakeLong(Word(Frame), Word(Frame)));
  10200. end;
  10201.  
  10202. procedure TAnimate.Stop;
  10203. begin
  10204.   { Seek to first frame }
  10205.   Perform(ACM_PLAY, 1, MakeLong(StartFrame, StartFrame));
  10206.   FActive := False;
  10207. end;
  10208.  
  10209. { TToolButton }
  10210.  
  10211. constructor TToolButton.Create(AOwner: TComponent);
  10212. begin
  10213.   inherited Create(AOwner);
  10214.   ControlStyle := [csCaptureMouse, csSetCaption];
  10215.   Width := 23;
  10216.   Height := 22;
  10217.   FStyle := tbsButton;
  10218. end;
  10219.  
  10220. destructor TToolButton.Destroy;
  10221. begin
  10222.   if Assigned(FToolBar) then FToolBar.RemoveButton(Self);
  10223.   inherited Destroy;
  10224. end;
  10225.  
  10226. procedure TToolButton.MouseDown(Button: TMouseButton; Shift: TShiftState;
  10227.   X, Y: Integer);
  10228. begin
  10229.   if (Button = mbLeft) and Enabled then Down := not Down;
  10230.   inherited MouseDown(Button, Shift, X, Y);
  10231.   if not Assigned(OnMouseDown) then DoDropDown;
  10232. end;
  10233.  
  10234. procedure TToolButton.MouseMove(Shift: TShiftState; X, Y: Integer);
  10235. var
  10236.   CopyMove: TPoint;
  10237. begin
  10238.   { We need to send move messages to the same place in the parent so
  10239.     that any WM_NCHITTEST messages may be passed to Windows.  Doing
  10240.     this we get the hot-tracking effect when moving mouse over
  10241.     Flat toolbars (e.g. IE3). }
  10242.   if not (csDesigning in ComponentState) and not FInMouseMove then
  10243.   begin
  10244.     CopyMove := Parent.ScreenToClient(ClientToScreen(Point(X, Y)));
  10245.     FInMouseMove := True;
  10246.     try
  10247.       FDoHitTest := True;
  10248.       Parent.Perform(WM_MOUSEMOVE, 0, MakeLParam(CopyMove.X, CopyMove.Y));
  10249.     finally
  10250.       FInMouseMove := False;
  10251.     end;
  10252.   end;
  10253.   inherited MouseMove(Shift, X, Y);
  10254.   if MouseCapture then
  10255.     Down := (X >= 0) and (X < ClientWidth) and (Y >= 0) and (Y <= ClientHeight);
  10256. end;
  10257.  
  10258. procedure TToolButton.MouseUp(Button: TMouseButton; Shift: TShiftState;
  10259.   X, Y: Integer);
  10260. var
  10261.   DoClick: Boolean;
  10262. begin
  10263.   inherited MouseUp(Button, Shift, X, Y);
  10264.   if Button = mbLeft then
  10265.   begin
  10266.     DoClick := (X >= 0) and (X < ClientWidth) and (Y >= 0) and (Y <= ClientHeight);
  10267.     if Style <> tbsCheck then Down := False;
  10268.     Update;
  10269.     if DoClick then Click;
  10270.   end;
  10271. end;
  10272.  
  10273. procedure TToolButton.CMTextChanged(var Message: TMessage);
  10274. begin
  10275.   inherited;
  10276.   UpdateControl;
  10277. end;
  10278.  
  10279. procedure TToolButton.WMWindowPosChanged(var Message: TWMWindowPosChanged);
  10280. var
  10281.   I: Integer;
  10282.   Adjust: Integer;
  10283. begin
  10284.   if (FUpdateCount = 0) and not (csLoading in ComponentState) and
  10285.     Assigned(FToolBar) then
  10286.   begin
  10287.     FToolBar.OrderButton(Index);
  10288.     if FToolBar.ShowCaptions then
  10289.       Adjust := FToolBar.FHeightMargin
  10290.     else
  10291.       Adjust := 0;
  10292.  
  10293.     if (Width = FToolBar.ButtonWidth) and (Height = FToolBar.ButtonHeight) then
  10294.       FToolBar.RepositionButtons
  10295.     else if not (Style in [tbsSeparator, tbsDivider]) or
  10296.       (Height - Adjust <> FToolBar.ButtonHeight) then
  10297.     begin
  10298.       FToolBar.BeginUpdate;
  10299.       try
  10300.         if not (Style in [tbsSeparator, tbsDivider]) then
  10301.           FToolBar.ButtonWidth := Width;
  10302.         FToolBar.ButtonHeight := Height;
  10303.       finally
  10304.         FToolBar.EndUpdate;
  10305.       end;
  10306.       FToolBar.Recreate;
  10307.     end
  10308.     else
  10309.     begin
  10310.       UpdateControl;
  10311.       for I := Index to FToolBar.ButtonCount - 1 do
  10312.         FToolBar.RepositionButton(I);
  10313.     end;
  10314.   end;
  10315. end;
  10316.  
  10317. procedure TToolButton.Paint;
  10318. var
  10319.   R: TRect;
  10320. begin
  10321.   if not Assigned(FToolBar) then Exit;
  10322.   if Style = tbsDivider then
  10323.     with Canvas do
  10324.     begin
  10325.       R := Rect(Width div 2 - 1, 1, Width, Height - 1);
  10326.       DrawEdge(Handle, R, EDGE_ETCHED, BF_LEFT)
  10327.     end;
  10328.   if csDesigning in ComponentState then
  10329.     { Draw separator outline }
  10330.     if Style in [tbsSeparator, tbsDivider] then
  10331.       with Canvas do
  10332.       begin
  10333.         Pen.Style := psDot;
  10334.         Pen.Color := clBtnShadow;
  10335.         Brush.Style := bsClear;
  10336.         Rectangle(0, 0, ClientWidth, ClientHeight);
  10337.       end
  10338.     { Draw Flat button face }
  10339.     else if FToolBar.Flat then
  10340.       with Canvas do
  10341.       begin
  10342.         R := Rect(0, 0, Width, Height);
  10343.         if Down then DrawEdge(Handle, R, BDR_SUNKENOUTER, BF_RECT)
  10344.         else DrawEdge(Handle, R, BDR_RAISEDINNER, BF_RECT)
  10345.       end;
  10346. end;
  10347.  
  10348. const
  10349.   ButtonStates: array[TToolButtonState] of Word = (TBSTATE_CHECKED,
  10350.     TBSTATE_PRESSED, TBSTATE_ENABLED, TBSTATE_HIDDEN, TBSTATE_INDETERMINATE,
  10351.     TBSTATE_WRAP, TBSTATE_ELLIPSES);
  10352.  
  10353.   ButtonStyles: array[TToolButtonStyle] of Word = (TBSTYLE_BUTTON, TBSTYLE_CHECK,
  10354.     TBSTYLE_DROPDOWN, TBSTYLE_SEP, TBSTYLE_SEP);
  10355.  
  10356. function TToolButton.GetButtonState: Word;
  10357. begin
  10358.   Result := 0;
  10359.   if Down then
  10360.     if Style = tbsCheck then
  10361.       Result := Result or ButtonStates[tbsChecked]
  10362.     else
  10363.       Result := Result or ButtonStates[tbsPressed];
  10364.   if Enabled then Result := Result or ButtonStates[tbsEnabled];
  10365.   if not Visible then Result := Result or ButtonStates[tbsHidden];
  10366.   if FIndeterminate then Result := Result or ButtonStates[tbsIndeterminate];
  10367.   if FWrap then Result := Result or ButtonStates[tbsWrap];
  10368. //  if FEllipses then Result := Result or ButtonStates[tbsEllipses];
  10369. end;
  10370.  
  10371. function TToolButton.IsDown: Boolean;
  10372. begin
  10373.   Result := Assigned(FToolBar) and ((Style = tbsCheck) and
  10374.     (FToolBar.Perform(TB_ISBUTTONCHECKED, Index, 0) > 0) or
  10375.     ((Style <> tbsCheck) and
  10376.     (FToolBar.Perform(TB_ISBUTTONPRESSED, Index, 0) > 0)));
  10377. end;
  10378.  
  10379. procedure TToolButton.SetToolBar(AToolBar: TToolBar);
  10380. begin
  10381.   if FToolBar <> AToolBar then
  10382.   begin
  10383.     if FToolBar <> nil then FToolBar.RemoveButton(Self);
  10384.     Parent := AToolBar;
  10385.     if AToolBar <> nil then AToolBar.InsertButton(Self);
  10386.   end;
  10387. end;
  10388.  
  10389. procedure TToolButton.CMVisibleChanged(var Message: TMessage);
  10390. begin
  10391.   if not (csDesigning in ComponentState) and Assigned(FToolBar) then
  10392.     FToolBar.Perform(TB_HIDEBUTTON, Index, Ord(not Visible));
  10393. end;
  10394.  
  10395. procedure TToolButton.CMEnabledChanged(var Message: TMessage);
  10396. begin
  10397.   if Assigned(FToolBar) then
  10398.     FToolBar.Perform(TB_ENABLEBUTTON, Index, Ord(Enabled));
  10399. end;
  10400.  
  10401. procedure TToolButton.SetDown(Value: Boolean);
  10402. begin
  10403.   if (csReading in ComponentState) then
  10404.   begin
  10405.     if Value then FStreamedDown := Value;
  10406.   end
  10407.   else if (Down <> Value) and Assigned(FToolBar) then
  10408.   begin
  10409.     if Style = tbsCheck then
  10410.       FToolBar.Perform(TB_CHECKBUTTON, Index, MakeLong(Ord(Value), 0))
  10411.     else
  10412.       FToolBar.Perform(TB_PRESSBUTTON, Index, MakeLong(Ord(Value), 0));
  10413.     FDown := IsDown;
  10414.   end;
  10415. end;
  10416.  
  10417. (*
  10418. procedure TToolButton.SetEllipses(Value: Boolean);
  10419. begin
  10420.   if FEllipses <> Value then
  10421.   begin
  10422.     FEllipses := Value;
  10423.     UpdateControl;
  10424.   end;
  10425. end;
  10426. *)
  10427.  
  10428. procedure TToolButton.SetGrouped(Value: Boolean);
  10429. begin
  10430.   if FGrouped <> Value then
  10431.   begin
  10432.     FGrouped := Value;
  10433.     UpdateControl;
  10434.   end;
  10435. end;
  10436.  
  10437. procedure TToolButton.SetImageIndex(Value: Integer);
  10438. begin
  10439.   if FImageIndex <> Value then
  10440.   begin
  10441.     FImageIndex := Value;
  10442.     UpdateControl;
  10443.   end;
  10444. end;
  10445.  
  10446. procedure TToolButton.SetIndeterminate(Value: Boolean);
  10447. begin
  10448.   if FIndeterminate <> Value then
  10449.   begin
  10450.     FIndeterminate := Value;
  10451.     FToolBar.Perform(TB_INDETERMINATE, Index, Ord(FIndeterminate));
  10452.   end;
  10453. end;
  10454.  
  10455. procedure TToolButton.SetStyle(Value: TToolButtonStyle);
  10456. begin
  10457.   if FStyle <> Value then
  10458.   begin
  10459.     FStyle := Value;
  10460.     UpdateControl;
  10461.     { Might have widened the button }
  10462.     if (Style = tbsDropDown) and not (csLoading in ComponentState)
  10463.       and Assigned(FToolBar) then FToolBar.RepositionButtons;
  10464.   end;
  10465. end;
  10466.  
  10467. procedure TToolButton.SetWrap(Value: Boolean);
  10468. begin
  10469.   if FWrap <> Value then
  10470.   begin
  10471.     FWrap := Value;
  10472.     if not (csLoading in ComponentState) and Assigned(FToolBar) then
  10473.     begin
  10474.       FToolBar.Recreate;
  10475.       FToolBar.UpdateButtons;
  10476.       FToolBar.RepositionButtons;
  10477.     end;
  10478.   end;
  10479. end;
  10480.  
  10481. procedure TToolButton.CMHitTest(var Message: TCMHitTest);
  10482. begin
  10483.   inherited;
  10484.   if FDoHitTest then
  10485.   begin
  10486.     Message.Result := Ord(csDesigning in ComponentState);
  10487.     FDoHitTest := False;
  10488.   end;
  10489. end;
  10490.  
  10491. procedure TToolButton.BeginUpdate;
  10492. begin
  10493.   Inc(FUpdateCount);
  10494. end;
  10495.  
  10496. procedure TToolButton.EndUpdate;
  10497. begin
  10498.   Dec(FUpdateCount);
  10499. //  Changed;
  10500. end;
  10501.  
  10502. function TToolButton.GetIndex: Integer;
  10503. begin
  10504.   if Assigned(FToolBar) then
  10505.     Result := FToolBar.FButtons.IndexOf(Self)
  10506.   else
  10507.     Result := -1;
  10508. end;
  10509.  
  10510. procedure TToolButton.UpdateControl;
  10511. begin
  10512.   if not (csLoading in ComponentState) and Assigned(FToolBar) then
  10513.     FToolBar.UpdateButton(Index);
  10514. end;
  10515.  
  10516. procedure TToolButton.DoDropDown;
  10517. var
  10518.   P: TPoint;
  10519. begin
  10520.   if Assigned(PopupMenu) then
  10521.   begin
  10522.     P := ClientToScreen(Point(0, ClientHeight));
  10523.     PopupMenu.PopUp(P.X, P.Y);
  10524.     Down := False;
  10525.   end;
  10526. end;
  10527.  
  10528. { TToolBar }
  10529.  
  10530. constructor TToolBar.Create(AOwner: TComponent);
  10531. begin
  10532.   inherited Create(AOwner);
  10533.   ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents,
  10534.     csDoubleClicks];
  10535.   Height := 32;
  10536.   Align := alTop;
  10537.   BorderStyle := bsNone;
  10538.   FButtonWidth := 23;
  10539.   FButtonHeight := 22;
  10540.   FBitmapWidth := 16;
  10541.   FBitmapHeight := 16;
  10542.   FDivider := True;
  10543.   FWrapable := True;
  10544.   FButtons := TList.Create;
  10545.   FImageChangeLink := TChangeLink.Create;
  10546.   FImageChangeLink.OnChange := ImageListChange;
  10547.   FDisabledImageChangeLink := TChangeLink.Create;
  10548.   FDisabledImageChangeLink.OnChange := DisabledImageListChange;
  10549.   FHotImageChangeLink := TChangeLink.Create;
  10550.   FHotImageChangeLink.OnChange := HotImageListChange;
  10551.   FBitmap := TBitmap.Create;
  10552.   FNullBitmap := TBitmap.Create;
  10553.   with FNullBitmap do
  10554.   begin
  10555.     Width := 1;
  10556.     Height := 1;
  10557.     Canvas.Brush.Color := clBtnFace;
  10558.     Canvas.FillRect(Rect(0,0,1,1));
  10559.   end;
  10560. end;
  10561.  
  10562. destructor TToolBar.Destroy;
  10563. var
  10564.   I: Integer;
  10565. begin
  10566.   FNullBitmap.Free;
  10567.   FBitmap.Free;
  10568.   FHotImageChangeLink.Free;
  10569.   FImageChangeLink.Free;
  10570.   for I := 0 to FButtons.Count - 1 do
  10571.     if TControl(FButtons[I]) is TToolButton then
  10572.       TToolButton(FButtons[I]).FToolBar := nil;
  10573.   FButtons.Free;
  10574.   inherited Destroy;
  10575. end;
  10576.  
  10577. procedure TToolBar.CreateParams(var Params: TCreateParams);
  10578. const
  10579.   AdjustStyles = CCS_ADJUSTABLE or TBSTYLE_ALTDRAG;
  10580.   DefaultStyles = CCS_NOPARENTALIGN or CCS_NOMOVEY or CCS_NORESIZE;
  10581.   DividerStyles: array[Boolean] of Integer = (CCS_NODIVIDER, 0);
  10582.   ListStyles: array[Boolean] of Integer = (0, TBSTYLE_LIST);
  10583.   FlatStyles: array[Boolean] of Integer = (0, TBSTYLE_FLAT);
  10584.   WrapStyles: array[Boolean] of Integer = (0, TBSTYLE_WRAPABLE);
  10585. begin
  10586.   { Returns true if we can use new features (e.g. image lists) }
  10587.   FNewStyle := InitCommonControl(ICC_BAR_CLASSES);
  10588.   inherited CreateParams(Params);
  10589.   CreateSubClass(Params, TOOLBARCLASSNAME);
  10590.   with Params do
  10591.   begin
  10592.     Style := Style or DefaultStyles or
  10593.       DividerStyles[FDivider and (BorderStyle = bsNone)] or FlatStyles[FFlat] or
  10594.       ListStyles[FList] or WrapStyles[FWrapable];
  10595.     WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);
  10596.   end;
  10597. end;
  10598.  
  10599. procedure TToolBar.CreateWnd;
  10600. var
  10601.   DisplayDC: HDC;
  10602.   StockFont: HFONT;
  10603.   TxtMetric: TTEXTMETRIC;
  10604. begin
  10605.   inherited CreateWnd;
  10606.   StockFont := GetStockObject(SYSTEM_FONT);
  10607.   if StockFont <> 0 then
  10608.   begin
  10609.     DisplayDC := GetDC(0);
  10610.     if (DisplayDC <> 0) then
  10611.     begin
  10612.       if (SelectObject(DisplayDC, StockFont) <> 0) then
  10613.         if (GetTextMetrics(DisplayDC, TxtMetric)) then
  10614.         with TxtMetric do
  10615.           FHeightMargin := tmHeight - tmInternalLeading - tmExternalLeading;
  10616.       ReleaseDC(0, DisplayDC);
  10617.     end;
  10618.   end;
  10619.   Recreate;
  10620. end;
  10621.  
  10622. procedure TToolBar.CreateButtons;
  10623. var
  10624.   W, H: Integer;
  10625. begin
  10626.   SendMessage(Handle, TB_BUTTONSTRUCTSIZE, SizeOf(TTBButton), 0);
  10627.   W := FButtonWidth;
  10628.   H := FButtonHeight;
  10629.   if ShowCaptions then Dec(H, FHeightMargin + 1);
  10630.   SendMessage(Handle, TB_SETBUTTONSIZE, 0, MakeLParam(W, H));
  10631.   W := FBitmapWidth;
  10632.   H := FBitmapHeight;
  10633.   SendMessage(Handle, TB_SETBITMAPSIZE, 0, MakeLParam(W, H));
  10634.   SendMessage(Handle, TB_SETINDENT, FIndent, 0);
  10635.   UpdateButtons;
  10636.   UpdateImages;
  10637. end;
  10638.  
  10639. procedure TToolBar.RepositionButton(const Index: Integer);
  10640. var
  10641.   TBButton: TTBButton;
  10642.   Button: TControl;
  10643.   R: TRect;
  10644.   AdjustY: Integer;
  10645. begin
  10646.   if SendMessage(Handle, TB_GETBUTTON, Index, Longint(@TBButton)) = 0 then Exit;
  10647.   Button := TControl(TBButton.dwData);
  10648.   if Button is TToolButton then TToolButton(Button).BeginUpdate;  // Necessary?
  10649.   try
  10650.     SendMessage(Handle, TB_GETITEMRECT, Index, Longint(@R));
  10651.     if (Button is TWinControl) and TWinControl(Button).HandleAllocated then
  10652.     with TWinControl(Button) do
  10653.     begin
  10654.       { Check for a control that doesn't size and center it }
  10655.       if Height <= R.Bottom - R.Top then
  10656.       begin
  10657.         AdjustY := (R.Bottom - R.Top - Height) div 2;
  10658.         SetBounds(R.Left, R.Top + AdjustY, R.Right - R.Left, Height);
  10659.       end
  10660.       else
  10661.         BoundsRect := R;
  10662.     end
  10663.     else
  10664.       Button.BoundsRect := R;
  10665.   finally
  10666.     if Button is TToolButton then TToolButton(Button).EndUpdate; // Necessary ?
  10667.   end;
  10668. end;
  10669.  
  10670. procedure TToolBar.RepositionButtons;
  10671. var
  10672.   I: Integer;
  10673. begin
  10674.   if FUpdateCount > 0 then Exit;
  10675.   BeginUpdate;
  10676.   try
  10677.     for I := ButtonCount - 1 downto 0 do RepositionButton(I);
  10678.   finally
  10679.     EndUpdate;
  10680.   end;
  10681. end;
  10682.  
  10683. procedure TToolBar.SetButtonWidth(Value: Integer);
  10684. var
  10685.   I: Integer;
  10686.   Control: TControl;
  10687. begin
  10688.   if FButtonWidth <> Value then
  10689.   begin
  10690.     BeginUpdate;
  10691.     try
  10692.       for I := FButtons.Count - 1 downto 0 do
  10693.       begin
  10694.         Control := FButtons[I];
  10695.         if (Control is TToolButton) and
  10696.           not (TToolButton(Control).Style in [tbsSeparator, tbsDivider]) then
  10697.         begin
  10698.           if Control is TToolButton then
  10699.             TToolButton(Control).BeginUpdate;
  10700.           try
  10701.             if Control.Width <> Value then
  10702.               Control.Width := Value;
  10703.           finally
  10704.             if Control is TToolButton then
  10705.               TToolButton(Control).EndUpdate;
  10706.           end;
  10707.         end;
  10708.       end;
  10709.     finally
  10710.       EndUpdate;
  10711.     end;
  10712.     FButtonWidth := Value;
  10713.   end;
  10714.   Recreate;
  10715. end;
  10716.  
  10717. procedure TToolBar.SetButtonHeight(Value: Integer);
  10718. var
  10719.   I: Integer;
  10720.   Control: TControl;
  10721.   Adjust: Integer;
  10722. begin
  10723.   if FButtonHeight <> Value then
  10724.   begin
  10725.     if ShowCaptions then
  10726.       Adjust := FHeightMargin
  10727.     else
  10728.       Adjust := 0;
  10729.     BeginUpdate;
  10730.     try
  10731.       for I := FButtons.Count - 1 downto 0 do
  10732.       begin
  10733.         Control := FButtons[I];
  10734.         if Control is TToolButton then
  10735.           TToolButton(Control).BeginUpdate;
  10736.         try
  10737.           if Control is TToolButton then
  10738.           begin
  10739.             if Control.Height <> Value - Adjust then
  10740.               Control.Height := Value - Adjust;
  10741.           end
  10742.           else
  10743.           begin
  10744.             if Control.Height <> Value then
  10745.               Control.Height := Value;
  10746.           end;
  10747.         finally
  10748.           if Control is TToolButton then
  10749.             TToolButton(Control).EndUpdate;
  10750.         end;
  10751.       end;
  10752.     finally
  10753.       EndUpdate;
  10754.     end;
  10755.     FButtonHeight := Value;
  10756.   end;
  10757.   Recreate;
  10758. end;
  10759.  
  10760. procedure TToolBar.InsertButton(Control: TControl);
  10761. var
  10762.   Pos: Integer;
  10763. begin
  10764.   { Establish negotiations for TToolButtons }
  10765.   if Control is TToolButton then TToolButton(Control).FToolBar := Self;
  10766.   Pos := FButtons.Add(Control);
  10767.   UpdateButton(Pos);
  10768. end;
  10769.  
  10770. procedure TToolBar.RemoveButton(Control: TControl);
  10771. var
  10772.   I, Pos: Integer;
  10773. begin
  10774.   I := FButtons.IndexOf(Control);
  10775.   if I >= 0 then
  10776.   begin
  10777.     if Control is TToolButton then TToolButton(Control).FToolBar := nil;
  10778.     Pos := FButtons.Remove(Control);
  10779.     SendMessage(Handle, TB_DELETEBUTTON, Pos, 0);
  10780.     for I := Pos to ButtonCount - 1 do RepositionButton(I);
  10781.   end;
  10782. end;
  10783.  
  10784. procedure TToolBar.UpdateItem(const Message, FromIndex, ToIndex: Integer);
  10785. var
  10786.   Button: TTBButton;
  10787.   Buffer: array[0..4095] of Char;
  10788. begin
  10789.   with TControl(FButtons[FromIndex]) do
  10790.   begin
  10791.     if ClassType = TToolButton then
  10792.     with TToolButton(FButtons[FromIndex]) do
  10793.     begin
  10794.       FillChar(Button, SizeOf(Button), 0);
  10795.       if Style in [tbsSeparator, tbsDivider] then
  10796.       begin
  10797.         Button.iBitmap := Width;
  10798.         Button.idCommand := -1;
  10799.       end
  10800.       else
  10801.       begin
  10802.         Button.iBitmap := ImageIndex;
  10803.         Button.idCommand := FromIndex;
  10804.       end;
  10805.       Button.fsStyle := ButtonStyles[Style];
  10806.       Button.fsState := GetButtonState;
  10807.       if FGrouped then Button.fsStyle := Button.fsStyle or TBSTYLE_GROUP;
  10808.       Button.dwData := Longint(FButtons[FromIndex]);
  10809.       if ShowCaptions then
  10810.       begin
  10811.         StrPCopy(Buffer, Caption);
  10812.         { TB_ADDSTRING requires two null terminators }
  10813.         Buffer[Length(Caption) + 1] := #0;
  10814.         Button.iString := SendMessage(Self.Handle, TB_ADDSTRING, 0, Longint(@Buffer));
  10815.       end
  10816.       else
  10817.         Button.iString := -1;
  10818.     end
  10819.     else
  10820.     begin
  10821.       FillChar(Button, SizeOf(Button), 0);
  10822.       Button.fsStyle := ButtonStyles[tbsSeparator];
  10823.       Button.iBitmap := Width;
  10824.       Button.idCommand := -1;
  10825.       Button.dwData := Longint(FButtons[FromIndex]);
  10826.       Button.iString := -1;
  10827.     end;
  10828.     SendMessage(Handle, Message, ToIndex, Integer(@Button));
  10829.   end;
  10830. end;
  10831.  
  10832. procedure TToolBar.UpdateButton(const Index: Integer);
  10833. begin
  10834.   if (FUpdateCount = 0) and not (csLoading in ComponentState) then
  10835.   begin
  10836.     BeginUpdate;
  10837.     try
  10838.       if SendMessage(Handle, TB_DELETEBUTTON, Index, 0) = 1 then
  10839.         UpdateItem(TB_INSERTBUTTON, Index, Index)
  10840.       else
  10841.         UpdateItem(TB_ADDBUTTONS, Index, 1)
  10842.     finally
  10843.       EndUpdate;
  10844.     end;
  10845.     ResizeButtons;
  10846.   end;
  10847.   RepositionButton(Index);
  10848. end;
  10849.  
  10850. procedure TToolBar.UpdateButtons;
  10851. var
  10852.   I: Integer;
  10853. begin
  10854.   if (FUpdateCount = 0) and not (csLoading in ComponentState) then
  10855.   begin
  10856.     BeginUpdate;
  10857.     try
  10858.       for I := 0 to ButtonCount - 1 do
  10859.         SendMessage(Handle, TB_DELETEBUTTON, 0, 0);
  10860.       for I := 0 to FButtons.Count - 1 do UpdateItem(TB_ADDBUTTONS, I, 1);
  10861.     finally
  10862.       EndUpdate;
  10863.     end;
  10864.     ResizeButtons;
  10865.   end;
  10866. end;
  10867.  
  10868. procedure TToolBar.ClearButtons;
  10869. var
  10870.   Count: Integer;
  10871. begin
  10872.   BeginUpdate;
  10873.   try
  10874.     Count := ButtonCount;
  10875.     while Count > 0 do
  10876.     begin
  10877.       SendMessage(Handle, TB_DELETEBUTTON, 0, 0);
  10878.       Dec(Count);
  10879.     end;
  10880.   finally
  10881.     EndUpdate;
  10882.   end;
  10883.   ResizeButtons;
  10884. end;
  10885.  
  10886. procedure TToolBar.CMControlChange(var Message: TCMControlChange);
  10887. begin
  10888.   with Message do
  10889.     if Inserting then
  10890.       InsertButton(Control)
  10891.     else
  10892.       RemoveButton(Control);
  10893. end;
  10894.  
  10895. procedure TToolBar.CMColorChanged(var Message: TMessage);
  10896. begin
  10897.   inherited;
  10898.   RecreateWnd;
  10899. end;
  10900.  
  10901. procedure TToolBar.SetAutoSize(Value: Boolean);
  10902. begin
  10903.   if FAutoSize <> Value then
  10904.   begin
  10905.     FAutoSize := Value;
  10906.     RecreateWnd;
  10907.   end;
  10908. end;
  10909.  
  10910. procedure TToolBar.SetShowCaptions(Value: Boolean);
  10911. begin
  10912.   if FShowCaptions <> Value then
  10913.   begin
  10914.     FShowCaptions := Value;
  10915.     RecreateWnd;
  10916.   end;
  10917. end;
  10918.  
  10919. procedure TToolBar.LoadImage(AImages: TImageList);
  10920. var
  10921.   AddBitmap: TTBAddBitmap;
  10922.   ReplaceBitmap: TTBReplaceBitmap;
  10923.   Count: Integer;
  10924. begin
  10925.   FOldHandle := FBitmap.Handle;
  10926.   if Assigned(AImages) then
  10927.   begin
  10928.     FBitmap.Handle := AImages.GetImageBitmap;
  10929.     Count := AImages.Count;
  10930.   end
  10931.   else
  10932.   begin
  10933.     FBitmap.Assign(FNullBitmap);
  10934.     Count := 1;
  10935.   end;
  10936.   FBitmap.HandleType := bmDIB;
  10937.   if (csLoading in ComponentState) or (FOldHandle = 0) then
  10938.   begin
  10939.     AddBitmap.hInst := 0;
  10940.     AddBitmap.nID := FBitmap.Handle;
  10941.     SendMessage(Handle, TB_ADDBITMAP, Count, Longint(@AddBitmap));
  10942.   end
  10943.   else
  10944.   begin
  10945.     ReplaceBitmap.hInstOld := 0;
  10946.     ReplaceBitmap.nIDOld := FOldHandle;
  10947.     ReplaceBitmap.hInstNew := 0;
  10948.     ReplaceBitmap.nIDNew := FBitmap.Handle;
  10949.     ReplaceBitmap.nButtons := Count;
  10950.     SendMessage(Handle, TB_REPLACEBITMAP, 0, Longint(@ReplaceBitmap));
  10951.   end;
  10952. end;
  10953.  
  10954. function TToolBar.GetRowCount: Integer;
  10955. begin
  10956.   Result := Perform(TB_GETROWS, 0, 0);
  10957. end;
  10958.  
  10959. procedure TToolBar.SetDivider(Value: Boolean);
  10960. begin
  10961.   if FDivider <> Value then
  10962.   begin
  10963.     FDivider := Value;
  10964.     RecreateWnd;
  10965.   end;
  10966. end;
  10967.  
  10968. procedure TToolBar.SetList(Value: Boolean);
  10969. begin
  10970.   if FList <> Value then
  10971.   begin
  10972.     FList := Value;
  10973.     RecreateWnd;
  10974.   end;
  10975. end;
  10976.  
  10977. procedure TToolBar.SetFlat(Value: Boolean);
  10978. begin
  10979.   if FFlat <> Value then
  10980.   begin
  10981.     FFlat := Value;
  10982.     RecreateWnd;
  10983.   end;
  10984. end;
  10985.  
  10986. procedure TToolBar.SetWrapable(Value: Boolean);
  10987. begin
  10988.   if FWrapable <> Value then
  10989.   begin
  10990.     FWrapable := Value;
  10991.     RecreateWnd;
  10992.   end;
  10993. end;
  10994.  
  10995. procedure TToolBar.Resize;
  10996. begin
  10997.   if Assigned(FOnResize) then FOnResize(Self);
  10998. end;
  10999.  
  11000. procedure TToolBar.WMEraseBkgnd(var Message: TWMEraseBkgnd);
  11001. begin
  11002.   if Flat then
  11003.   begin
  11004.     DefaultHandler(Message);
  11005.     RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_ALLCHILDREN);
  11006.   end
  11007.   else inherited;
  11008. end;
  11009.  
  11010. procedure TToolBar.WMSize(var Message: TWMSize);
  11011. begin
  11012.   { Eat WM_SIZE message to prevent control from doing alignment }
  11013.   if not (csLoading in ComponentState) then Resize;
  11014.   if Wrapable then ResizeButtons;
  11015. end;
  11016.  
  11017. procedure TToolBar.Notification(AComponent: TComponent;
  11018.   Operation: TOperation);
  11019. begin
  11020.   inherited Notification(AComponent, Operation);
  11021.   if Operation = opRemove then
  11022.   begin
  11023.     if AComponent = FImages then FImages := nil;
  11024.     if AComponent = FHotImages then FHotImages := nil;
  11025.     if AComponent = FDisabledImages then FDisabledImages := nil;
  11026.   end;
  11027. end;
  11028.  
  11029. procedure TToolBar.UpdateImages;
  11030. begin
  11031.   if FImages <> nil then
  11032.     SetImageList(FImages.Handle)
  11033.   else
  11034.     { If control doesn't support image lists then assign a null bitmap }
  11035.     if not FNewStyle then LoadImage(nil);
  11036.   if FDisabledImages <> nil then SetDisabledImageList(FDisabledImages.Handle);
  11037.   if FHotImages <> nil then SetHotImageList(FHotImages.Handle);
  11038. end;
  11039.  
  11040. procedure TToolBar.ImageListChange(Sender: TObject);
  11041. begin
  11042.   if HandleAllocated and (Sender = Images) then Recreate;
  11043. end;
  11044.  
  11045. procedure TToolBar.SetImageList(Value: HImageList);
  11046. begin
  11047.   if HandleAllocated then
  11048.   begin
  11049.     { Have to add bitmaps using TB_ADDBITMAP if old style controls }
  11050.     if FNewStyle then
  11051.       SendMessage(Handle, TB_SETIMAGELIST, 0, Value)
  11052.     else
  11053.       LoadImage(Images);
  11054.     Invalidate;
  11055.   end;
  11056. end;
  11057.  
  11058. procedure TToolBar.SetImages(Value: TImageList);
  11059. begin
  11060.   if FImages <> nil then FImages.UnRegisterChanges(FImageChangeLink);
  11061.   FImages := Value;
  11062.   if FImages <> nil then
  11063.   begin
  11064.     FImages.RegisterChanges(FImageChangeLink);
  11065.     FBitmapWidth := FImages.Width;
  11066.     FBitmapHeight := FImages.Height;
  11067.     Recreate;
  11068.   end
  11069.   else SetImageList(0);
  11070. end;
  11071.  
  11072. procedure TToolBar.DisabledImageListChange(Sender: TObject);
  11073. begin
  11074.   if HandleAllocated and (Sender = DisabledImages) then Recreate;
  11075. end;
  11076.  
  11077. procedure TToolBar.SetDisabledImageList(Value: HImageList);
  11078. begin
  11079.   { Cannot support Disabled images using old style controls }
  11080.   if HandleAllocated and FNewStyle then
  11081.     SendMessage(Handle, TB_SETDisabledIMAGELIST, 0, Value);
  11082.   Invalidate;
  11083. end;
  11084.  
  11085. procedure TToolBar.SetDisabledImages(Value: TImageList);
  11086. begin
  11087.   if FDisabledImages <> nil then FDisabledImages.UnRegisterChanges(FDisabledImageChangeLink);
  11088.   FDisabledImages := Value;
  11089.   if FDisabledImages <> nil then
  11090.   begin
  11091.     FDisabledImages.RegisterChanges(FDisabledImageChangeLink);
  11092.     Recreate;
  11093.   end
  11094.   else SetDisabledImageList(0);
  11095. end;
  11096.  
  11097. procedure TToolBar.HotImageListChange(Sender: TObject);
  11098. begin
  11099.   if HandleAllocated and (Sender = HotImages) then Recreate;
  11100. end;
  11101.  
  11102. procedure TToolBar.SetHotImageList(Value: HImageList);
  11103. begin
  11104.   { Cannot support hot images using old style controls }
  11105.   if HandleAllocated and FNewStyle then
  11106.     SendMessage(Handle, TB_SETHOTIMAGELIST, 0, Value);
  11107.   Invalidate;
  11108. end;
  11109.  
  11110. procedure TToolBar.SetHotImages(Value: TImageList);
  11111. begin
  11112.   if FHotImages <> nil then FHotImages.UnRegisterChanges(FHotImageChangeLink);
  11113.   FHotImages := Value;
  11114.   if FHotImages <> nil then
  11115.   begin
  11116.     FHotImages.RegisterChanges(FHotImageChangeLink);
  11117.     Recreate;
  11118.   end
  11119.   else SetHotImageList(0);
  11120. end;
  11121.  
  11122. procedure TToolBar.SetIndent(Value: Integer);
  11123. begin
  11124.   if FIndent <> Value then
  11125.   begin
  11126.     FIndent := Value;
  11127.     RecreateWnd;
  11128.   end;
  11129. end;
  11130.  
  11131. procedure TToolBar.Recreate;
  11132. begin
  11133.   if (FUpdateCount = 0) and not (csLoading in ComponentState) then CreateButtons;
  11134. end;
  11135.  
  11136. procedure TToolBar.Reposition;
  11137. var
  11138.   LastIndex: Integer;
  11139.   R: TRect;
  11140. begin
  11141.   LastIndex := ButtonCount - 1;
  11142.   if LastIndex >= 0 then
  11143.   begin
  11144.     SendMessage(Handle, TB_GETITEMRECT, LastIndex, Longint(@R));
  11145.     if Align in [alLeft, alRight] then
  11146.       ClientWidth := R.Right
  11147.     else
  11148.       ClientHeight := R.Bottom;
  11149.   end;
  11150. end;
  11151.  
  11152. procedure TToolBar.TBAutoSize(var Message: TMessage);
  11153. begin
  11154.   if (csLoading in ComponentState) or (FUpdateCount > 0) then Exit;
  11155.   inherited;
  11156.   RepositionButtons;
  11157.   if FAutoSize then Reposition;
  11158. end;
  11159.  
  11160. procedure TToolBar.GetChildren(Proc: TGetChildProc; Root: TComponent);
  11161. var
  11162.   I: Integer;
  11163.   Control: TControl;
  11164. begin
  11165.   for I := 0 to FButtons.Count - 1 do Proc(TComponent(FButtons[I]));
  11166.   for I := 0 to ControlCount - 1 do
  11167.   begin
  11168.     Control := Controls[I];
  11169.     if (Control.Owner = Root) and (FButtons.IndexOf(Control) = -1) then Proc(Control);
  11170.   end;
  11171. end;
  11172.  
  11173. procedure TToolBar.Loaded;
  11174. var
  11175.   I: Integer;
  11176. begin
  11177.   inherited Loaded;
  11178.   Recreate;
  11179.   for I := 0 to FButtons.Count - 1 do
  11180.     if (TControl(FButtons[I]) is TToolButton) then
  11181.     with TToolButton(FButtons[I]) do
  11182.       if FStreamedDown then
  11183.       begin
  11184.         Down := True;
  11185.         FStreamedDown := False;
  11186.       end;
  11187. end;
  11188.  
  11189. procedure TToolBar.BeginUpdate;
  11190. begin
  11191.   Inc(FUpdateCount);
  11192. end;
  11193.  
  11194. procedure TToolBar.EndUpdate;
  11195. begin
  11196.   Dec(FUpdateCount);
  11197. //  Changed;
  11198. end;
  11199.  
  11200. procedure TToolBar.ResizeButtons;
  11201. begin
  11202.   SendMessage(Handle, TB_AUTOSIZE, 0, 0);
  11203. end;
  11204.  
  11205. function TToolBar.ButtonCount: Integer;
  11206. begin
  11207.   Result := SendMessage(Handle, TB_BUTTONCOUNT, 0, 0);
  11208. end;
  11209.  
  11210. procedure TToolBar.OrderButton(const Index: Integer);
  11211. var
  11212.   Control: TControl;
  11213.   Reposition: Boolean;
  11214.   I, NewIndex, OldIndex: Integer;
  11215.   Pos: Integer;
  11216.   Candidates: TList;
  11217. begin
  11218.   if FUpdateCount > 0 then Exit;
  11219.   Control := FButtons[Index];
  11220.   OldIndex := Index;
  11221.   Reposition := False;
  11222.   Candidates := TList.Create;
  11223.   try
  11224.     Pos := 0;
  11225.     for I := 0 to FButtons.Count - 1 do
  11226.     begin
  11227.       if (FButtons[I] <> Control) and (Control.Left <= TControl(FButtons[I]).Left) then
  11228.       begin
  11229.         Reposition := True;
  11230.         if (Candidates.Count > 0) and (Pos = TControl(FButtons[I]).Top) then Continue;
  11231.         Candidates.Add(FButtons[I]);
  11232.         Pos := TControl(FButtons[I]).Top;
  11233.         { Look for break }
  11234. //        Break;
  11235.       end;
  11236.     end;
  11237.     if Reposition then
  11238.     begin
  11239.       if (Candidates.Count > 1) then
  11240.       begin
  11241.         for I := Candidates.Count - 1 downto 0 do
  11242.           if (Control.Top >= TControl(Candidates[I]).Top) then Break;
  11243.         if I >= 0 then
  11244.           I := FButtons.IndexOf(Candidates[I])
  11245.         else
  11246.           Reposition := False;
  11247.       end
  11248.       else
  11249.         I := FButtons.IndexOf(Candidates[0]);
  11250.     end
  11251.     else
  11252.       I := -1;
  11253.   finally
  11254.     Candidates.Free;
  11255.   end;
  11256.  
  11257.   if not Reposition and (Control.Left > TControl(FButtons.Last).Left) then
  11258.   begin
  11259.     Reposition := True;
  11260.     I := FButtons.Count;
  11261.   end;
  11262.  
  11263.   if Reposition then
  11264.   begin
  11265.     { If we are inserting to the right of our deletion then adjust }
  11266.     if I = OldIndex then Exit;
  11267.     if OldIndex < I then
  11268.       NewIndex := I - 1
  11269.     else
  11270.       NewIndex := I;
  11271.     FButtons.Delete(OldIndex);
  11272.     FButtons.Insert(NewIndex, Control);
  11273.     BeginUpdate;
  11274.     try
  11275.       SendMessage(Handle, TB_DELETEBUTTON, OldIndex, 0);
  11276.       UpdateItem(TB_INSERTBUTTON, NewIndex, NewIndex);
  11277.     finally
  11278.       EndUpdate;
  11279.     end;
  11280.   end;
  11281. end;
  11282.  
  11283. procedure TToolBar.CMRecreateWnd(var Message: TMessage);
  11284. var
  11285.   OldRect: TRect;
  11286. begin
  11287.   OldRect := BoundsRect;
  11288.   inherited;
  11289.   BoundsRect := OldRect;
  11290. end;
  11291.  
  11292. procedure TToolBar.AlignControls(AControl: TControl; var Rect: TRect);
  11293. var
  11294.   Index: Integer;
  11295. begin
  11296.   inherited AlignControls(AControl, Rect);
  11297.   if FUpdateCount > 0 then Exit;
  11298.   if not (AControl is TToolButton) then
  11299.   begin
  11300.     Index := FButtons.IndexOf(AControl);
  11301.     if Index >= 0 then
  11302.     begin
  11303.       if ButtonHeight <> AControl.Height then
  11304.       begin
  11305.         ButtonHeight := AControl.Height;
  11306.         Recreate;
  11307.       end;
  11308.       OrderButton(Index);
  11309.       UpdateButton(Index);
  11310.       RepositionButtons;
  11311.     end;
  11312.   end;
  11313. end;
  11314.  
  11315. { TCoolBand }
  11316.  
  11317. constructor TCoolBand.Create(Collection: TCollection);
  11318. begin
  11319.   FWidth := 40;
  11320.   FBreak := True;
  11321.   FColor := clBtnFace;
  11322.   FFixedBackground := True;
  11323.   FMinHeight := 26;
  11324.   FParentColor := True;
  11325.   FParentBitmap := True;
  11326.   FBitmap := TBitmap.Create;
  11327.   FBitmap.OnChange := BitmapChanged;
  11328.   FVisible := True;
  11329.   FDDB := TBitmap.Create;
  11330.   inherited Create(Collection);
  11331.   ParentColorChanged;
  11332.   ParentBitmapChanged;
  11333. end;
  11334.  
  11335. destructor TCoolBand.Destroy;
  11336. var
  11337.   AControl: TControl;
  11338. begin
  11339.   FDDB.Free;
  11340.   AControl := Control;
  11341.   FControl := nil;
  11342.   inherited Destroy;
  11343.   if Assigned(AControl) and not (csDestroying in AControl.ComponentState) then
  11344.     AControl.Perform(CM_SHOWINGCHANGED, 0, 0);
  11345. end;
  11346.  
  11347. procedure TCoolBand.Assign(Source: TPersistent);
  11348. begin
  11349.   if Source is TCoolBand then
  11350.   begin
  11351.     Text := TCoolBand(Source).Text;
  11352.     Width := TCoolBand(Source).Width;
  11353.   end
  11354.   else inherited Assign(Source);
  11355. end;
  11356.  
  11357. function TCoolBand.GetDisplayName: string;
  11358. begin
  11359.   Result := Text;
  11360.   if Result = '' then Result := inherited GetDisplayName;
  11361. end;
  11362.  
  11363. function TCoolBand.CoolBar: TCoolBar;
  11364. begin
  11365.   Result := TCoolBands(Collection).FCoolBar;
  11366. end;
  11367.  
  11368. procedure TCoolBand.ParentColorChanged;
  11369. begin
  11370.   if FParentColor then
  11371.   begin
  11372.     SetColor(CoolBar.Color);
  11373.     FParentColor := True;
  11374.   end;
  11375. end;
  11376.  
  11377. procedure TCoolBand.ParentBitmapChanged;
  11378. begin
  11379.   BitmapChanged(Self);
  11380. end;
  11381.  
  11382. procedure TCoolBand.BitmapChanged(Sender: TObject);
  11383. begin
  11384.   if not ParentBitmap then
  11385.   begin
  11386.     FDDB.Assign(FBitmap);
  11387.     if not FDDB.Empty then FDDB.HandleType := bmDDB;
  11388.   end
  11389.   else
  11390.     FDDB.Assign(nil);
  11391.   Changed(False);
  11392. end;
  11393.  
  11394. procedure TCoolBand.SetBitmap(Value: TBitmap);
  11395. begin
  11396.   FParentBitmap := False;
  11397.   FBitmap.Assign(Value);
  11398.   FReplace := True;
  11399.   try
  11400.     Changed(False);
  11401.   finally
  11402.     FReplace := False;
  11403.   end;
  11404. end;
  11405.  
  11406. function TCoolBand.GetHeight: Integer;
  11407. var
  11408.   I: Integer;
  11409.   H: Integer;
  11410. begin
  11411.   if CoolBar.HandleAllocated then
  11412.     with CoolBar do
  11413.     begin
  11414.       Result := Perform(RB_GETROWHEIGHT, Index, 0);
  11415.  
  11416.       { Check for an MS bug where the rowheight for a band is reported
  11417.         incorrectly when 1) the next band to follow it is a 'break' band,
  11418.         2) then next band's rowheight is larger than the one in question,
  11419.         3) there is more than one band in the row, and 4) it has no control. }
  11420.  
  11421.       { Is this band not a break band and without a control? }
  11422.       if not Break and not Assigned(Control) and (Index > 0) and
  11423.         (Index < Collection.Count - 1) then
  11424.       begin
  11425.  
  11426.         { Is the next band a 'break' band and it's size greater? }
  11427.         if {(TCoolBand(Collection.Items[Index + 1]).Break) and}
  11428.           (Perform(RB_GETROWHEIGHT, Index + 1, 0) = Result) then
  11429.         begin
  11430.           { If so, use the minimum height of the current row's bands }
  11431.           for I := Index - 1 downto 0 do
  11432.           begin
  11433.             H := Perform(RB_GETROWHEIGHT, I, 0);
  11434.             if H < Result then Result := H;
  11435.             if TCoolBand(Collection.Items[I]).Break then Exit;
  11436.           end;
  11437.         end;
  11438.       end;
  11439.     end
  11440.   else
  11441.     Result := 0;
  11442. end;
  11443.  
  11444. procedure TCoolBand.SetBorderStyle(Value: TBorderStyle);
  11445. begin
  11446.   if FBorderStyle <> Value then
  11447.   begin
  11448.     FBorderStyle := Value;
  11449.     Changed(False);
  11450.   end;
  11451. end;
  11452.  
  11453. procedure TCoolBand.SetBreak(Value: Boolean);
  11454. begin
  11455.   if FBreak <> Value then
  11456.   begin
  11457.     if Value and (Index = 0) then Exit; 
  11458.     FBreak := Value;
  11459.     Changed(False);
  11460.   end;
  11461. end;
  11462.  
  11463. procedure TCoolBand.SetFixedSize(Value: Boolean);
  11464. begin
  11465.   if FFixedSize <> Value then
  11466.   begin
  11467.     FFixedSize := Value;
  11468.     Changed(True);
  11469.   end;
  11470. end;
  11471.  
  11472. procedure TCoolBand.SetMinHeight(Value: Integer);
  11473. begin
  11474.   if FMinHeight <> Value then
  11475.   begin
  11476.     FMinHeight := Value;
  11477.     Changed(False);
  11478.   end;
  11479. end;
  11480.  
  11481. procedure TCoolBand.SetMinWidth(Value: Integer);
  11482. begin
  11483.   if FMinWidth <> Value then
  11484.   begin
  11485.     FMinWidth := Value;
  11486.     Changed(False);
  11487.   end;
  11488. end;
  11489.  
  11490. procedure TCoolBand.SetVisible(Value: Boolean);
  11491. begin
  11492.   if FVisible <> Value then
  11493.   begin
  11494.     FVisible := Value;
  11495.     Changed(True);
  11496.   end;
  11497. end;
  11498.  
  11499. procedure TCoolBand.SetHorizontalOnly(Value: Boolean);
  11500. begin
  11501.   if FHorizontalOnly <> Value then
  11502.   begin
  11503.     FHorizontalOnly := Value;
  11504.     Changed(False);
  11505.   end;
  11506. end;
  11507.  
  11508. procedure TCoolBand.SetImageIndex(Value: Integer);
  11509. begin
  11510.   if FImageIndex <> Value then
  11511.   begin
  11512.     FImageIndex := Value;
  11513.     Changed(False);
  11514.   end;
  11515. end;
  11516.  
  11517. procedure TCoolBand.SetFixedBackground(Value: Boolean);
  11518. begin
  11519.   if FFixedBackground <> Value then
  11520.   begin
  11521.     FFixedBackground := Value;
  11522.     Changed(False);
  11523.   end;
  11524. end;
  11525.  
  11526. procedure TCoolBand.SetColor(Value: TColor);
  11527. begin
  11528.   if FColor <> Value then
  11529.   begin
  11530.     FColor := Value;
  11531.     FParentColor := False;
  11532.     Changed(False);
  11533.   end;
  11534. end;
  11535.  
  11536. procedure TCoolBand.SetControl(Value: TWinControl);
  11537. var
  11538.   Band: TCoolBand;
  11539.   PrevControl: TWinControl;
  11540. begin
  11541.   if FControl <> Value then
  11542.   begin
  11543.     if Assigned(Value) then
  11544.     begin
  11545.       Band := TCoolBands(Collection).FindBand(Value);
  11546.       if Assigned(Band) and (Band <> Self) then Band.SetControl(nil);
  11547.     end;
  11548.     PrevControl := FControl;
  11549.     FControl := Value;
  11550.     FReplace := Assigned(Value) and (Text = '');
  11551.     try
  11552.       Changed(False);
  11553.     finally
  11554.       FReplace := False;
  11555.     end;
  11556.     if Assigned(PrevControl) then PrevControl.Perform(CM_SHOWINGCHANGED, 0, 0);
  11557.   end;
  11558. end;
  11559.  
  11560. procedure TCoolBand.SetText(const Value: string);
  11561. begin
  11562.   if FText <> Value then
  11563.   begin
  11564.     FText := Value;
  11565.     FReplace := True;
  11566.     try
  11567.       Changed(False);
  11568.     finally
  11569.       FReplace := False;
  11570.     end;
  11571.   end;
  11572. end;
  11573.  
  11574. function TCoolBand.IsColorStored: Boolean;
  11575. begin
  11576.   Result := not ParentColor;
  11577. end;
  11578.  
  11579. function TCoolBand.IsBitmapStored: Boolean;
  11580. begin
  11581.   Result := not ParentBitmap;
  11582. end;
  11583.  
  11584. procedure TCoolBand.SetParentColor(Value: Boolean);
  11585. begin
  11586.   if FParentColor <> Value then
  11587.   begin
  11588.     FParentColor := Value;
  11589.     if CoolBar <> nil then Changed(False);
  11590.   end;
  11591. end;
  11592.  
  11593. procedure TCoolBand.SetParentBitmap(Value: Boolean);
  11594. begin
  11595.   if FParentBitmap <> Value then
  11596.   begin
  11597.     FParentBitmap := Value;
  11598.     ParentBitmapChanged;
  11599.   end;
  11600. end;
  11601.  
  11602. procedure TCoolBand.SetWidth(Value: Integer);
  11603. begin
  11604.   if FWidth <> Value then
  11605.   begin
  11606.     FWidth := Value;
  11607.     Changed(False);
  11608.   end;
  11609. end;
  11610.  
  11611. { TCoolBands }
  11612.  
  11613. constructor TCoolBands.Create(CoolBar: TCoolBar);
  11614. begin
  11615.   inherited Create(TCoolBand);
  11616.   FCoolBar := CoolBar;
  11617.   FFixups := TStringList.Create;
  11618. end;
  11619.  
  11620. destructor TCoolBands.Destroy;
  11621. begin
  11622.   FFixups.Free;
  11623.   inherited Destroy;
  11624. end;
  11625.  
  11626. function TCoolBands.FindBand(AControl: TControl): TCoolBand;
  11627. var
  11628.   I: Integer;
  11629. begin
  11630.   for I := 0 to Count - 1 do
  11631.   begin
  11632.     Result := TCoolBand(inherited GetItem(I));
  11633.     if Result.FControl = AControl then Exit;
  11634.   end;
  11635.   Result := nil;
  11636. end;
  11637.  
  11638. function TCoolBands.HaveGraphic: Boolean;
  11639. var
  11640.   I: Integer;
  11641. begin
  11642.   Result := False;
  11643.   for I := 0 to Count - 1 do
  11644.     if not Items[I].FDDB.Empty then
  11645.     begin
  11646.       Result := True;
  11647.       Exit;
  11648.     end;
  11649. end;
  11650.  
  11651. function TCoolBands.GetItem(Index: Integer): TCoolBand;
  11652. begin
  11653.   Result := TCoolBand(inherited GetItem(Index));
  11654. end;
  11655.  
  11656. function TCoolBands.GetOwner: TPersistent;
  11657. begin
  11658.   Result := FCoolBar;
  11659. end;
  11660.  
  11661. procedure TCoolBands.SetItem(Index: Integer; Value: TCoolBand);
  11662. begin
  11663.   inherited SetItem(Index, Value);
  11664. end;
  11665.  
  11666. procedure TCoolBands.Update(Item: TCollectionItem);
  11667. begin
  11668.   FModified := True;
  11669.   if FUpdateCount <> 0 then Exit;
  11670.   with FCoolBar do
  11671.     if Item <> nil then
  11672.     begin
  11673.       if TCoolBand(Item).FReplace then
  11674.         ReplaceBand(Item.Index)
  11675.       else
  11676.         UpdateBand(RB_SETBANDINFO, Item.Index, Item.Index);
  11677.       if HandleAllocated and not (csLoading in ComponentState) then
  11678.         PostMessage(Handle, CM_BANDCHANGE, 0, 0);
  11679.     end
  11680.     else
  11681.       UpdateBands;
  11682. end;
  11683.  
  11684. { TCoolBar }
  11685.  
  11686. constructor TCoolBar.Create(AOwner: TComponent);
  11687. begin
  11688.   CheckCommonControl(ICC_COOL_CLASSES);
  11689.   inherited Create(AOwner);
  11690.   ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents, csOpaque,
  11691.     csDoubleClicks];
  11692.   Height := 75;
  11693.   Align := alTop;
  11694.   FBandBorderStyle := bsSingle;
  11695.   ParentColor := True;
  11696.   ParentFont := True;
  11697.   FBitmap := TBitmap.Create;
  11698.   FBitmap.OnChange := BitmapChanged;
  11699.   FShowText := True;
  11700.   FDoubleBuffered := True;
  11701.   FDDB := TBitmap.Create;
  11702.   FBands := TCoolBands.Create(Self);
  11703.   FImageChangeLink := TChangeLink.Create;
  11704.   FImageChangeLink.OnChange := ImageListChange;
  11705. end;
  11706.  
  11707. destructor TCoolBar.Destroy;
  11708. begin
  11709.   FImageChangeLink.Free;
  11710.   FBands.Free;
  11711.   FDDB.Free;
  11712.   FBitmap.Free;
  11713.   inherited Destroy;
  11714. end;
  11715.  
  11716. procedure TCoolBar.CreateParams(var Params: TCreateParams);
  11717. const
  11718.   DefaultStyles = CCS_NOPARENTALIGN or CCS_NORESIZE or CCS_NOMOVEY or
  11719.     CCS_NODIVIDER;
  11720.   AlignStyles: array[TAlign] of Integer = (CCS_NOMOVEY, CCS_TOP, CCS_BOTTOM,
  11721.     CCS_LEFT, CCS_RIGHT, CCS_NOMOVEY);
  11722.   AutoSizeStyles: array[Boolean] of Integer = (CCS_NORESIZE, 0);
  11723.   FixedStyles: array[Boolean] of Integer = (0, RBS_FIXEDORDER);
  11724.   BandBorderStyles: array[TBorderStyle] of Integer = (0, RBS_BANDBORDERS);
  11725.   HeightStyles: array[Boolean] of Integer = (RBS_VARHEIGHT, 0);
  11726.   VerticalStyles: array[Boolean] of Integer = (0, CCS_VERT);
  11727. begin
  11728.   inherited CreateParams(Params);
  11729.   CreateSubClass(Params, REBARCLASSNAME);
  11730.   with Params do
  11731.   begin
  11732.     Style := Style or DefaultStyles or AlignStyles[Align] or
  11733.       VerticalStyles[Vertical] or FixedStyles[FFixedOrder] or
  11734.       BandBorderStyles[FBandBorderStyle] or HeightStyles[FFixedSize];
  11735.     WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);
  11736.   end;
  11737. end;
  11738.  
  11739. procedure TCoolBar.CreateWnd;
  11740. begin
  11741.   inherited CreateWnd;
  11742.   if not (csLoading in ComponentState) then UpdateBands;
  11743. end;
  11744.  
  11745. procedure TCoolBar.Loaded;
  11746. begin
  11747.   inherited Loaded;
  11748.   UpdateBands;
  11749. end;
  11750.  
  11751. procedure TCoolBar.AlignControls(AControl: TControl; var Rect: TRect);
  11752. var
  11753.   Band: TCoolBand;
  11754. begin
  11755.   if not (csDestroying in ComponentState) and (not Assigned(AControl) or
  11756.     (AControl is TWinControl)) then
  11757.   begin
  11758.     { Refresh bands if any control changed }
  11759.     if Assigned(AControl) then
  11760.     begin
  11761.       Band := FBands.FindBand(AControl as TWinControl);
  11762.       if Band <> nil then
  11763.       begin
  11764.         if {csDesigning in ComponentState}True then
  11765.         begin
  11766.           FBands.FUpdateCount := 1;
  11767.           try
  11768.             if Vertical then
  11769.               Band.Width := AControl.Height + GetGripSize(Band) + 1
  11770.             else
  11771.               Band.Width := AControl.Width + GetGripSize(Band) + 1;
  11772.             if Vertical then
  11773.               Band.MinHeight := AControl.Width
  11774.             else
  11775.               Band.MinHeight := AControl.Height;
  11776.           finally
  11777.             Bands.FUpdateCount := 0;
  11778.           end;
  11779.           Bands.Update(Band);
  11780.         end
  11781.         else
  11782.           RefreshBand(Band.Index);
  11783.       end;
  11784.     end;
  11785.   end
  11786.   else inherited AlignControls(AControl, Rect);
  11787. end;
  11788.  
  11789. procedure TCoolBar.Change;
  11790. var
  11791.   Form: TCustomForm;
  11792. begin
  11793.   if not FBands.FModified then Exit;
  11794.   begin
  11795.     Form := GetParentForm(Self);
  11796.     if (Form <> nil) and (Form.Designer <> nil) then Form.Designer.Modified;
  11797.   end;
  11798.   if Assigned(FOnChange) then FOnChange(Self);
  11799. end;
  11800.  
  11801. procedure TCoolBar.Resize;
  11802. begin
  11803.   if Assigned(FOnResize) then FOnResize(Self);
  11804. end;
  11805.  
  11806. procedure TCoolBar.WMSetCursor(var Message: TWMSetCursor);
  11807. var
  11808.   P: TPoint;
  11809. begin
  11810.   if (csDesigning in ComponentState) then
  11811.   begin
  11812.     GetCursorPos(P);
  11813.     P := ScreenToClient(P);
  11814.     if Perform(CM_DESIGNHITTEST, 0, MakeLong(P.X, P.Y)) = 1 then
  11815.     begin
  11816.       DefaultHandler(Message);
  11817.       Exit;
  11818.     end;
  11819.   end;
  11820.   inherited;
  11821. end;
  11822.  
  11823. function TCoolBar.GetAlign: TAlign;
  11824. begin
  11825.   Result := inherited Align;
  11826. end;
  11827.  
  11828. procedure TCoolBar.SetAlign(Value: TAlign);
  11829. begin
  11830.   if Align <> Value then
  11831.   begin
  11832.     inherited Align := Value;
  11833.     Vertical := Align in [alLeft, alRight];
  11834.   end;
  11835. end;
  11836.  
  11837. procedure TCoolBar.SetAutoSize(Value: Boolean);
  11838. begin
  11839.   if FAutoSize <> Value then
  11840.   begin
  11841.     FAutoSize := Value;
  11842.     RecreateWnd;
  11843.   end;
  11844. end;
  11845.  
  11846. procedure TCoolBar.SetBands(Value: TCoolBands);
  11847. begin
  11848.   FBands.Assign(Value);
  11849. end;
  11850.  
  11851. procedure TCoolBar.SetBandBorderStyle(Value: TBorderStyle);
  11852. begin
  11853.   if FBandBorderStyle <> Value then
  11854.   begin
  11855.     FBandBorderStyle := Value;
  11856.     RecreateWnd;
  11857.   end;
  11858. end;
  11859.  
  11860. procedure TCoolBar.SetFixedSize(Value: Boolean);
  11861. begin
  11862.   if FFixedSize <> Value then
  11863.   begin
  11864.     FFixedSize := Value;
  11865.     RecreateWnd;
  11866.   end;
  11867. end;
  11868.  
  11869. procedure TCoolBar.SetFixedOrder(Value: Boolean);
  11870. begin
  11871.   if FFixedOrder <> Value then
  11872.   begin
  11873.     FFixedOrder := Value;
  11874.     RecreateWnd;
  11875.   end;
  11876. end;
  11877.  
  11878. procedure TCoolBar.ImageListChange(Sender: TObject);
  11879. begin
  11880.   if HandleAllocated and (Sender = Images) then
  11881.     SetImageList(Images.Handle);
  11882. end;
  11883.  
  11884. procedure TCoolBar.SetImageList(Value: HImageList);
  11885. var
  11886.   BarInfo: TReBarInfo;
  11887. begin
  11888.   if HandleAllocated then
  11889.   begin
  11890.     BarInfo.cbSize := SizeOf(TReBarInfo);
  11891.     BarInfo.fMask := RBIM_IMAGELIST;
  11892.     BarInfo.himl := Value;
  11893.     SendMessage(Handle, RB_SETBARINFO, 0, Integer(@BarInfo))
  11894.   end;
  11895. end;
  11896.  
  11897. procedure TCoolBar.SetImages(Value: TImageList);
  11898. begin
  11899.   if FImages <> nil then FImages.UnRegisterChanges(FImageChangeLink);
  11900.   FImages := Value;
  11901.   if FImages <> nil then
  11902.   begin
  11903.     FImages.RegisterChanges(FImageChangeLink);
  11904.     SetImageList(FImages.Handle);
  11905.   end
  11906.   else SetImageList(0);
  11907. end;
  11908.  
  11909. procedure TCoolBar.SetShowText(Value: Boolean);
  11910. begin
  11911.   if FShowText <> Value then
  11912.   begin
  11913.     FShowText := Value;
  11914.     UpdateBands;
  11915.   end;
  11916. end;
  11917.  
  11918. procedure TCoolBar.Notification(AComponent: TComponent;
  11919.   Operation: TOperation);
  11920. var
  11921.   Band: TCoolBand;
  11922. begin
  11923.   inherited Notification(AComponent, Operation);
  11924.   if not (csDestroying in ComponentState) and (Operation = opRemove) then
  11925.   begin
  11926.     if (AComponent is TWinControl) then
  11927.     begin
  11928.       Band := Bands.FindBand(TControl(AComponent));
  11929.       if Assigned(Band) then Band.FControl := nil;
  11930.     end
  11931.     else if AComponent = FImages then FImages := nil;
  11932.   end;
  11933. end;
  11934.  
  11935. function TCoolBar.GetPalette: HPALETTE;
  11936. begin
  11937.   if not FDDB.Empty then
  11938.     Result := FDDB.Palette
  11939.   else
  11940.     Result := inherited GetPalette;
  11941. end;
  11942.  
  11943. procedure TCoolBar.BitmapChanged(Sender: TObject);
  11944. var
  11945.   I: Integer;
  11946. begin
  11947.   FDDB.Assign(FBitmap);
  11948.   if not FDDB.Empty then FDDB.HandleType := bmDDB;
  11949.   for I := 0 to FBands.Count - 1 do Bands[I].ParentBitmapChanged;
  11950.   if HandleAllocated then RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_ERASE or RDW_ALLCHILDREN);
  11951. end;
  11952.  
  11953. procedure TCoolBar.SetBitmap(Value: TBitmap);
  11954. begin
  11955.   FBitmap.Assign(Value);
  11956. end;
  11957.  
  11958. procedure TCoolBar.SetVertical(Value: Boolean);
  11959. begin
  11960.   if FVertical <> Value then
  11961.   begin
  11962.     FVertical := Value;
  11963.     RecreateWnd;
  11964.   end;
  11965. end;
  11966.  
  11967. procedure TCoolBar.RefreshBand(const Index: Integer);
  11968. var
  11969.   BandInfo: TReBarBandInfo;
  11970. begin
  11971.   if HandleAllocated then
  11972.   begin
  11973.     with Bands[Index] do
  11974.     begin
  11975.       if Assigned(Control) then
  11976.       begin
  11977.         BandInfo.cbSize := SizeOf(TReBarBandInfo);
  11978.         BandInfo.hwndChild := Control.Handle;
  11979.         BandInfo.fMask := RBBIM_CHILD;
  11980.         SendMessage(Handle, RB_SETBANDINFO, Index, Integer(@BandInfo));
  11981.       end;
  11982.     end;
  11983.   end;
  11984. end;
  11985.  
  11986. procedure TCoolBar.InvalidateBand(Index: Integer);
  11987. begin
  11988.   { TODO: invalidate only the band's rectangle }
  11989.   if HandleAllocated then
  11990.     RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_ERASE or RDW_ALLCHILDREN);
  11991. end;
  11992.  
  11993. procedure TCoolBar.ReplaceBand(Index: Integer);
  11994. begin
  11995.   SendMessage(Handle, WM_SETREDRAW, 0, 0);
  11996.   try
  11997.    SendMessage(Handle, RB_DELETEBAND, Index, 0);
  11998.     UpdateBand(RB_INSERTBAND, Index, Index);
  11999.   finally
  12000.     SendMessage(Handle, WM_SETREDRAW, 1, 0);
  12001.   end;
  12002.   InvalidateBand(Index);
  12003. end;
  12004.  
  12005. procedure TCoolBar.UpdateBand(const Message, FromIndex, ToIndex: Integer);
  12006. const
  12007.   BreakStyles: array[Boolean] of Integer = (0, RBBS_BREAK);
  12008.   FixedSizeStyles: array[Boolean] of Integer = (0, RBBS_FIXEDSIZE);
  12009.   BorderStyles: array[TBorderStyle] of Integer = (0, RBBS_CHILDEDGE);
  12010.   VerticalStyles: array[Boolean] of Integer = (0, RBBS_NOVERT);
  12011.   FixedBmpStyles: array[Boolean] of Integer = (0, RBBS_FIXEDBMP);
  12012. var
  12013.   BandInfo: TReBarBandInfo;
  12014.   Band: TCoolBand;
  12015.   Text: string;
  12016. begin
  12017.   if HandleAllocated then
  12018.   begin
  12019.     Band := Bands[FromIndex];
  12020.     if Assigned(Band.Control) then Band.Control.Visible := Visible;
  12021.     if not Band.Visible then Exit;
  12022.     FillChar(BandInfo, SizeOf(BandInfo), 0);
  12023.     with BandInfo do
  12024.     begin
  12025.       cbSize := SizeOf(TReBarBandInfo);
  12026.       wID := Integer(Band);
  12027.       if Band.ParentColor then
  12028.         clrBack := ColorToRGB(Color)
  12029.       else
  12030.         clrBack := ColorToRGB(Band.Color);
  12031.       fStyle := BreakStyles[Band.Break] or FixedSizeStyles[Band.FixedSize] or
  12032.         BorderStyles[Band.BorderStyle] or VerticalStyles[Band.HorizontalOnly] or
  12033.         FixedBmpStyles[Band.FixedBackground];
  12034.       fMask := RBBIM_STYLE or RBBIM_COLORS or RBBIM_SIZE or RBBIM_BACKGROUND or
  12035.          RBBIM_IMAGE or RBBIM_ID;
  12036.       if Band.ParentBitmap then
  12037.         hbmBack := FDDB.Handle
  12038.       else
  12039.         hbmBack := Band.FDDB.Handle;
  12040.       iImage := Band.ImageIndex;
  12041.       if Assigned(Band.Control) then hwndChild := Band.Control.Handle;
  12042.       cx := Band.Width;
  12043. (*
  12044.       if Band.FixedSize and (Band.MinWidth <= 0) then
  12045.         cxMinChild := cx
  12046.       else
  12047.         cxMinChild := Band.MinWidth;
  12048. *)
  12049.       cxMinChild := Band.MinWidth;
  12050.       cyMinChild := Band.MinHeight;
  12051.       fMask := fMask or RBBIM_CHILD or RBBIM_CHILDSIZE;
  12052.       if ShowText then
  12053.       begin
  12054.         if not Assigned(Band.Control) and (Band.Text = '') then
  12055.           Text := Band.GetDisplayName
  12056.         else
  12057.           Text := Band.Text;
  12058.         lpText := PChar(Text);
  12059.         fMask := fMask or RBBIM_TEXT;
  12060.       end;
  12061.     end;
  12062.     SendMessage(Handle, Message, ToIndex, Integer(@BandInfo));
  12063.   end;
  12064. end;
  12065.  
  12066. procedure TCoolBar.ReadBands;
  12067. var
  12068.   I: Integer;
  12069.   BandInfo: TReBarBandInfo;
  12070.   Band: TCoolBand;
  12071. begin
  12072.   { Grab current band settings }
  12073.   if Bands.FUpdateCount > 0 then Exit;
  12074.   FBands.FModified := False;
  12075.   BandInfo.cbSize := SizeOf(TReBarBandInfo);
  12076.   BandInfo.fMask := RBBIM_STYLE or RBBIM_SIZE or RBBIM_ID;
  12077.   FBands.FUpdateCount := 1;
  12078.   try
  12079.     for I := 0 to Perform(RB_GETBANDCOUNT, 0, 0) - 1 do
  12080.       if (Perform(RB_GETBANDINFO, I, Integer(@BandInfo)) <> 0) and
  12081.         (BandInfo.wID <> 0) then
  12082.         with BandInfo do
  12083.         begin
  12084.           Band := TCoolBand(wID);
  12085.           with Band do
  12086.           begin
  12087.             Break := fStyle and RBBS_BREAK <> 0;
  12088.             Width := cx;
  12089.             Index := I;
  12090.           end;
  12091.         end;
  12092.     if FBands.FModified then Change;
  12093.   finally
  12094.     FBands.FUpdateCount := 0;
  12095.   end;
  12096. end;
  12097.  
  12098. procedure TCoolBar.UpdateBands;
  12099. var
  12100.   I: Integer;
  12101. begin
  12102.   if HandleAllocated then
  12103.   begin
  12104.     FBands.FUpdateCount := 1;
  12105.     SendMessage(Handle, WM_SETREDRAW, 0, 0);
  12106.     try
  12107.       for I := 0 to SendMessage(Handle, RB_GETBANDCOUNT, 0, 0) - 1 do
  12108.         SendMessage(Handle, RB_DELETEBAND, 0, 0);
  12109.       for I := 0 to Bands.Count - 1 do UpdateBand(RB_INSERTBAND, I, -1);
  12110.     finally
  12111.       SendMessage(Handle, WM_SETREDRAW, 1, 0);
  12112.       FBands.FUpdateCount := 0;
  12113.     end;
  12114.     Perform(WM_SIZE, 0, 0);
  12115.     RedrawWindow(Handle, nil, 0, RDW_ERASE or RDW_INVALIDATE or RDW_ALLCHILDREN);
  12116.   end;
  12117. end;
  12118.  
  12119. { Return height/width (depending on Vertical property) of coolbar client area }
  12120. function TCoolBar.GetDisplaySize: Integer;
  12121. const
  12122.   BandBorderSize: array[TBorderStyle] of Integer = (0, 2);
  12123. var
  12124.   BandCount: Integer;
  12125.   BandInfo: TReBarBandInfo;
  12126.   I, Len, MaxLen: Integer;
  12127. begin
  12128.   Result := 0;
  12129.   BandCount := Perform(RB_GETBANDCOUNT, 0, 0);
  12130.   if BandCount > 0 then
  12131.   begin
  12132.     MaxLen := 0;
  12133.     BandInfo.cbSize := SizeOf(TReBarBandInfo);
  12134.     BandInfo.fMask := RBBIM_STYLE or RBBIM_ID;
  12135.     for I := 0 to BandCount - 1 do
  12136.       if (Perform(RB_GETBANDINFO, I, Integer(@BandInfo)) <> 0) and
  12137.         (BandInfo.wID <> 0) then
  12138.       begin
  12139.         Len := TCoolBand(BandInfo.wID).Height + BandBorderSize[BandBorderStyle];
  12140.         if BandInfo.fStyle and RBBS_BREAK <> 0 then
  12141.         begin
  12142.           Inc(Result, MaxLen);
  12143.           MaxLen := 0;
  12144.         end;
  12145.         if Len > MaxLen then MaxLen := Len;
  12146.       end;
  12147.     Inc(Result, MaxLen - BandBorderSize[BandBorderStyle])
  12148.   end;
  12149. end;
  12150.  
  12151. { Return height/width (depending on Vertical property) of coolbar grip area }
  12152. function TCoolBar.GetGripSize(Band: TCoolBand): Integer;
  12153.  
  12154.   { Coolbars take their text font from Windows' caption font minus any bold
  12155.     characteristics it may have. }
  12156.   function CaptionFont: HFont;
  12157.   var
  12158.     NonClientMetrics: TNonClientMetrics;
  12159.   begin
  12160.     with NonClientMetrics do
  12161.     begin
  12162.       cbSize := sizeof(TNonClientMetrics);
  12163.       if not SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, @NonClientMetrics, 0) then
  12164.         GetObject(GetStockObject(SYSTEM_FONT), SizeOf(lfCaptionFont), @lfCaptionFont);
  12165.       { Remove any bold styles }
  12166.       lfCaptionFont.lfWeight := FW_NORMAL;
  12167.       Result := CreateFontIndirect(lfCaptionFont)
  12168.     end;
  12169.   end;
  12170.  
  12171. const
  12172.   GripSize = 11;
  12173. var
  12174.   Text: string;
  12175. begin
  12176.   Result := 0;
  12177.   if Assigned(Band) and not Band.FixedSize then
  12178.   begin
  12179.     if ShowText then
  12180.     begin
  12181.       if not Assigned(Band.Control) and (Text = '') then
  12182.         Text := Band.GetDisplayName
  12183.       else
  12184.         Text := Band.Text;
  12185.       with TControlCanvas.Create do
  12186.       try
  12187.         Control := Self;
  12188.         Font.Handle := CaptionFont;
  12189.         Result := TextWidth(Text) + 4; { magic margin value }
  12190.       finally
  12191.         Free;
  12192.       end;
  12193.     end;
  12194.     if not FixedOrder or (Band.Index > 0) then Inc(Result, GripSize);
  12195.   end;
  12196. end;
  12197.  
  12198. { Return true if given point is within one of the grip areas }
  12199. function TCoolBar.PtInGripRect(const Pos: TPoint): Boolean;
  12200. var
  12201.   BandCount: Integer;
  12202.   BandInfo: TReBarBandInfo;
  12203.   I: Integer;
  12204.   W, H: Integer;
  12205.   X, Y, PrevW, PrevH: Integer;
  12206.   R: TRect;
  12207. begin
  12208.   Result := True;
  12209.   BandCount := Perform(RB_GETBANDCOUNT, 0, 0);
  12210.   if BandCount > 0 then
  12211.   begin
  12212.     X := 0;
  12213.     Y := 0;
  12214.     PrevW := 0;
  12215.     PrevH := 0;
  12216.     BandInfo.cbSize := SizeOf(TReBarBandInfo);
  12217.     BandInfo.fMask := RBBIM_STYLE or RBBIM_SIZE or RBBIM_ID;
  12218.     for I := 0 to BandCount - 1 do
  12219.       if (Perform(RB_GETBANDINFO, I, Integer(@BandInfo)) <> 0) and
  12220.         (BandInfo.wID <> 0) then
  12221.       begin
  12222.         if (BandInfo.fStyle and RBBS_BREAK <> 0) or (I = 0) then
  12223.         begin
  12224.           X := 1;
  12225.           Inc(Y, PrevH + 1);
  12226.         end
  12227.         else
  12228.           Inc(X, PrevW);
  12229.         W := GetGripSize(TCoolBand(BandInfo.wID));
  12230.         H := TCoolBand(BandInfo.wID).Height + 1;
  12231.         R := Rect(X, Y, X + W, Y + H);
  12232.         if PtInRect(R, Pos) then Exit;
  12233.         PrevH := H;
  12234.         PrevW := BandInfo.cx;
  12235.       end;
  12236.   end;
  12237.   Result := False;
  12238. end;
  12239.  
  12240. procedure TCoolBar.CMSysColorChange(var Message: TMessage);
  12241. begin
  12242.   inherited;
  12243.   RecreateWnd;
  12244. end;
  12245.  
  12246. procedure TCoolBar.CMColorChanged(var Message: TMessage);
  12247. var
  12248.   I: Integer;
  12249. begin
  12250.   inherited;
  12251.   for I := 0 to FBands.Count - 1 do Bands[I].ParentColorChanged;
  12252.   if HandleAllocated then InvalidateRect(Handle, nil, True);
  12253. end;
  12254.  
  12255. procedure TCoolBar.CMControlChange(var Message: TCMControlChange);
  12256. var
  12257.   Band: TCoolBand;
  12258. begin
  12259.   { Can only accept TWinControl descendants }
  12260.   if not (csLoading in ComponentState) and (Message.Control is TWinControl) then
  12261.     if Message.Inserting then
  12262.       with TCoolBand(Bands.Add) do SetControl(TWinControl(Message.Control))
  12263.     else
  12264.     begin
  12265.       Band := Bands.FindBand(Message.Control);
  12266.       if Assigned(Band) then Band.Free;
  12267.     end;
  12268. end;
  12269.  
  12270. procedure TCoolBar.CMDesignHitTest(var Message: TCMDesignHitTest);
  12271. begin
  12272.   if PtInGripRect(SmallPointToPoint(Message.Pos)) then
  12273.     Message.Result := 1
  12274.   else
  12275.     inherited;
  12276. end;
  12277.  
  12278. procedure TCoolBar.WMCaptureChanged(var Message: TMessage);
  12279. begin
  12280.   inherited;
  12281.   { Synchronize band properties - something may have changed }
  12282.   PostMessage(Handle, CM_BANDCHANGE, 0, 0);
  12283. end;
  12284.  
  12285. procedure TCoolBar.WMEraseBkgnd(var Message: TWMEraseBkgnd);
  12286. var
  12287.   R, R1, R2: TRect;
  12288. begin
  12289.   if not FDDB.Empty or Bands.HaveGraphic then
  12290.   begin
  12291.     DefaultHandler(Message);
  12292.     { Bug in control causes regions not covered by the bitmap to be left
  12293.       unerased.  We do it ourselves only if autosizing is not enabled. }
  12294.     if not AutoSize then
  12295.     begin
  12296.       if Vertical then
  12297.         R1 := Rect(0, 0, GetDisplaySize, ClientHeight)
  12298.       else
  12299.         R1 := Rect(0, 0, ClientWidth, GetDisplaySize);
  12300.       R2 := ClientRect;
  12301.       { Take into account the borders between bands }
  12302.       SubtractRect(R, R2, R1);
  12303.       if BandBorderStyle = bsSingle then
  12304.         if Vertical then
  12305.         begin
  12306.           Dec(R.Top, 1);
  12307.           Inc(R.Bottom, 5);
  12308.         end
  12309.         else
  12310.         begin
  12311.           Dec(R.Left, 1);
  12312.           Inc(R.Right, 5);
  12313.         end;
  12314.       FillRect(Message.DC, R, Brush.Handle);
  12315.       Message.Result := 1;
  12316.     end;
  12317.   end
  12318.   else
  12319.     inherited;
  12320. end;
  12321.  
  12322. procedure TCoolBar.AdjustSize;
  12323. begin
  12324.   if FBands.FUpdateCount > 0 then Exit;
  12325.   if Vertical then
  12326.     ClientWidth := GetDisplaySize
  12327.   else
  12328.     ClientHeight := GetDisplaySize;
  12329. end;
  12330.  
  12331. procedure TCoolBar.CMBandChange(var Message);
  12332. begin
  12333.   ReadBands;
  12334. end;
  12335.  
  12336. procedure TCoolBar.CNNotify(var Message: TWMNotify);
  12337. begin
  12338.   inherited;
  12339.   with Message.NMHdr^ do
  12340.     case code of
  12341.       RBN_HEIGHTCHANGE:
  12342.         begin
  12343.           if (ComponentState * [csLoading, csDestroying] = []) and
  12344.             HandleAllocated and AutoSize then
  12345.           begin
  12346.             ReadBands;
  12347.             AdjustSize;
  12348.           end;
  12349.         end;
  12350.     end;
  12351. end;
  12352.  
  12353. procedure TCoolBar.WMSize(var Message: TWMSize);
  12354. begin
  12355.   inherited;
  12356.   if not (csLoading in ComponentState) and AutoSize then AdjustSize;
  12357. end;
  12358.  
  12359. procedure TCoolBar.WndProc(var Message: TMessage);
  12360. begin
  12361.   if (csDesigning in ComponentState) then
  12362.     case Message.Msg of
  12363.       WM_MOUSEMOVE, WM_RBUTTONDBLCLK:
  12364.         begin
  12365.           { Enabled csDesignInteractive temporarily so that we may handle the
  12366.             design-time dragging of bands }
  12367.           ControlStyle := ControlStyle + [csDesignInteractive];
  12368.           try
  12369.             inherited;
  12370.           finally
  12371.             ControlStyle := ControlStyle - [csDesignInteractive];
  12372.           end;
  12373.           Exit;
  12374.         end;
  12375.       { We just dragged a band disable any drag events }
  12376.       WM_LBUTTONUP: ReleaseCapture;
  12377.     end;
  12378.   inherited;
  12379. end;
  12380.  
  12381. { TDateTimeColors }
  12382.  
  12383. const
  12384.   ColorIndex: array[0..5] of Integer = (MCSC_BACKGROUND, MCSC_TEXT,
  12385.     MCSC_TITLEBK, MCSC_TITLETEXT, MCSC_MONTHBK, MCSC_TRAILINGTEXT);
  12386.  
  12387. constructor TDateTimeColors.Create(AOwner: TDateTimePicker);
  12388. begin
  12389.   Owner := AOwner;
  12390.   FBackColor := clWindow;
  12391.   FTextColor := clWindowText;
  12392.   FTitleBackColor := clActiveCaption;
  12393.   FTitleTextColor := clWhite;
  12394.   FMonthBackColor := clWhite;
  12395.   FTrailingTextColor := clInactiveCaptionText;
  12396. end;
  12397.  
  12398. procedure TDateTimeColors.Assign(Source: TPersistent);
  12399. var
  12400.   SourceName: string;
  12401. begin
  12402.   if Source = nil then SourceName := 'nil'
  12403.   else SourceName := Source.ClassName;
  12404.   if (Source = nil) or not (Source is TDateTimeColors) then
  12405.     raise EConvertError.CreateFmt(SAssignError, [SourceName, ClassName]);
  12406.   FBackColor := TDateTimeColors(Source).BackColor;
  12407.   FTextColor := TDateTimeColors(Source).TextColor;
  12408.   FTitleBackColor := TDateTimeColors(Source).TitleBackColor;
  12409.   FTitleTextColor := TDateTimeColors(Source).TitleTextColor;
  12410.   FMonthBackColor := TDateTimeColors(Source).MonthBackColor;
  12411.   FTrailingTextColor := TDateTimeColors(Source).TrailingTextColor;
  12412. end;
  12413.  
  12414. procedure TDateTimeColors.SetColor(Index: Integer; Value: TColor);
  12415. begin
  12416.   DateTime_SetMonthCalColor(Owner.Handle, ColorIndex[Index], ColorToRGB(Value));
  12417.   case Index of
  12418.     0: FBackColor := Value;
  12419.     1: FTextColor := Value;
  12420.     2: FTitleBackColor := Value;
  12421.     3: FTitleTextColor := Value;
  12422.     4: FMonthBackColor := Value;
  12423.     5: FTrailingTextColor := Value;
  12424.   end;
  12425. end;
  12426.  
  12427. procedure TDateTimeColors.SetAllColors;
  12428. begin
  12429.   SetColor(0, FBackColor);
  12430.   SetColor(1, FTextColor);
  12431.   SetColor(2, FTitleBackColor);
  12432.   SetColor(3, FTitleTextColor);
  12433.   SetColor(4, FMonthBackColor);
  12434.   SetColor(5, FTrailingTextColor);
  12435. end;
  12436.  
  12437. { TDateTimePicker }
  12438.  
  12439. procedure RaiseDateTimeError(const Msg: string);
  12440. begin
  12441.   raise EDateTimeError.CreateFmt(SInvalidDate, [Msg]);
  12442. end;
  12443.  
  12444. constructor TDateTimePicker.Create(AOwner: TComponent);
  12445. begin
  12446.   CheckCommonControl(ICC_DATE_CLASSES);
  12447.   inherited Create(AOwner);
  12448.   ControlStyle := [csCaptureMouse, csOpaque, csClickEvents, csDoubleClicks,
  12449.     csFixedHeight];
  12450.   FCalColors := TDateTimeColors.Create(Self);
  12451.   FDateTime := Now;
  12452.   FShowCheckbox := False;
  12453.   FChecked := True;
  12454.   Width := 186;
  12455.   TabStop := True;
  12456.   AdjustHeight;
  12457. end;
  12458.  
  12459. destructor TDateTimePicker.Destroy;
  12460. begin
  12461.   FCalColors.Free;
  12462.   inherited Destroy;
  12463. end;
  12464.  
  12465. procedure TDateTimePicker.CreateParams(var Params: TCreateParams);
  12466. const
  12467.   Formats: array[TDTDateFormat] of Integer = (DTS_SHORTDATEFORMAT,
  12468.     DTS_LONGDATEFORMAT);
  12469. begin
  12470.   inherited CreateParams(Params);
  12471.   CreateSubClass(Params, DATETIMEPICK_CLASS);
  12472.   with Params do
  12473.   begin
  12474.     Style := Style or Formats[FDateFormat];
  12475.     if FDateMode = dmUpDown then Style := Style or DTS_UPDOWN;
  12476.     if FKind = dtkTime then Style := Style or DTS_TIMEFORMAT;
  12477.     if FCalAlignment = dtaRight then Style := Style or DTS_RIGHTALIGN;
  12478.     if FParseInput then Style := Style or DTS_APPCANPARSE;
  12479.     if FShowCheckbox then Style := Style or DTS_SHOWNONE;
  12480.     WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW) or
  12481.       CS_DBLCLKS;
  12482.   end;
  12483. end;
  12484.  
  12485. procedure TDateTimePicker.CreateWnd;
  12486. begin
  12487.   inherited CreateWnd;
  12488.   SetDateTime(FDateTime);
  12489.   FCalColors.SetAllColors;
  12490.   SetChecked(FChecked);
  12491. end;
  12492.  
  12493. procedure TDateTimePicker.CMColorChanged(var Message: TMessage);
  12494. begin
  12495.   inherited;
  12496.   InvalidateRect(Handle, nil, True);
  12497. end;
  12498.  
  12499. procedure TDateTimePicker.CMFontChanged(var Message: TMessage);
  12500. begin
  12501.   inherited;
  12502.   AdjustHeight;
  12503.   InvalidateRect(Handle, nil, True);
  12504. end;
  12505.  
  12506. procedure TDateTimePicker.CNNotify(var Message: TWMNotify);
  12507. var
  12508.   DT: TDateTime;
  12509.   AllowChange: Boolean;
  12510. begin
  12511.   with Message, Message.NMHdr^ do
  12512.   begin
  12513.     Result := 0;
  12514.     case code of
  12515.       DTN_CLOSEUP:
  12516.         if Assigned(FOnCloseUp) then FOnCloseUp(Self);
  12517.       DTN_DATETIMECHANGE:
  12518.         begin
  12519.           FDateTime := SystemTimeToDateTime(PNMDateTimeChange(NMHdr)^.st);
  12520.           if Assigned(FOnChange) then FOnChange(Self);
  12521.         end;
  12522.       DTN_DROPDOWN:
  12523.         if Assigned(FOnDropDown) then FOnDropDown(Self);
  12524.       DTN_USERSTRING:
  12525.         begin
  12526.           AllowChange := Assigned(FOnUserInput);
  12527.           with PNMDateTimeString(NMHdr)^ do
  12528.           begin
  12529.             if AllowChange then
  12530.             begin
  12531.               DT := 0.0;
  12532.               FOnUserInput(Self, pszUserString, DT, AllowChange);
  12533.               DateTimeToSystemTime(DT, st);
  12534.             end;
  12535.             dwFlags := Ord(not AllowChange);
  12536.           end;
  12537.         end;
  12538.     end;
  12539.   end;
  12540. end;
  12541.  
  12542. procedure TDateTimePicker.AdjustHeight;
  12543. var
  12544.   DC: HDC;
  12545.   SaveFont: HFont;
  12546.   SysMetrics, Metrics: TTextMetric;
  12547. begin
  12548.   DC := GetDC(0);
  12549.   GetTextMetrics(DC, SysMetrics);
  12550.   SaveFont := SelectObject(DC, Font.Handle);
  12551.   GetTextMetrics(DC, Metrics);
  12552.   SelectObject(DC, SaveFont);
  12553.   ReleaseDC(0, DC);
  12554.   Height := Metrics.tmHeight + (GetSystemMetrics(SM_CYBORDER) * 8);
  12555. end;
  12556.  
  12557. function TDateTimePicker.GetDate: TDate;
  12558. begin
  12559.   Result := TDate(FDateTime);
  12560. end;
  12561.  
  12562. function TDateTimePicker.GetTime: TTime;
  12563. begin
  12564.   Result := TTime(FDateTime);
  12565. end;
  12566.  
  12567. procedure TDateTimePicker.SetCalAlignment(Value: TDTCalAlignment);
  12568. begin
  12569.   if FCalAlignment <> Value then
  12570.   begin
  12571.     FCalAlignment := Value;
  12572.     if not (csDesigning in ComponentState) then RecreateWnd;
  12573.   end;
  12574. end;
  12575.  
  12576. procedure TDateTimePicker.SetCalColors(Value: TDateTimeColors);
  12577. begin
  12578.   if FCalColors <> Value then FCalColors.Assign(Value);
  12579. end;
  12580.  
  12581. procedure TDateTimePicker.SetChecked(Value: Boolean);
  12582. var
  12583.   ST: TSystemTime;
  12584. begin
  12585.   FChecked := Value;
  12586.   if FShowCheckbox then
  12587.   begin
  12588.     if Value then SetDateTime(FDateTime)
  12589.     else DateTime_SetSystemTime(Handle, GDT_NONE, ST);
  12590.     Invalidate;
  12591.   end;
  12592. end;
  12593.  
  12594. procedure TDateTimePicker.SetDate(Value: TDate);
  12595. begin
  12596.   if Trunc(FDateTime) <> Trunc(Value) then
  12597.   begin
  12598.     if Value = 0.0 then
  12599.     begin
  12600.       if not FShowCheckbox then raise EDateTimeError.Create(SNeedAllowNone);
  12601.       SetChecked(True);
  12602.     end
  12603.     else begin
  12604.       if (Double(FMaxDate) <> 0.0) and (Value > FMaxDate) then
  12605.         raise EDateTimeError.CreateFmt(SDateTimeMin, [DateToStr(FMaxDate)]);
  12606.       if (Double(FMinDate) <> 0.0) and (Value < FMinDate) then
  12607.         raise EDateTimeError.CreateFmt(SDateTimeMax, [DateToStr(FMaxDate)]);
  12608.       Value := Trunc(Value) + Frac(FDateTime);
  12609.       SetDateTime(Value);
  12610.     end;
  12611.   end;
  12612. end;
  12613.  
  12614. procedure TDateTimePicker.SetDateTime(Value: TDateTime);
  12615. var
  12616.   ST: TSystemTime;
  12617. begin
  12618.   DateTimeToSystemTime(Value, ST);
  12619.   if not DateTime_SetSystemTime(Handle, GDT_VALID, ST) then
  12620.     RaiseDateTimeError('');
  12621. end;
  12622.  
  12623. procedure TDateTimePicker.SetMaxDate(Value: TDate);
  12624. begin
  12625.   if FMaxDate <> Value then
  12626.   begin
  12627.     SetRange(FMinDate, Value);
  12628.     FMaxDate := Value;
  12629.   end;
  12630. end;
  12631.  
  12632. procedure TDateTimePicker.SetMinDate(Value: TDate);
  12633. begin
  12634.   if FMinDate <> Value then
  12635.   begin
  12636.     SetRange(Value, FMaxDate);
  12637.     FMinDate := Value;
  12638.   end;
  12639. end;
  12640.  
  12641. procedure TDateTimePicker.SetRange(MinVal, MaxVal: TDateTime);
  12642. var
  12643.   STA: packed array[1..2] of TSystemTime;
  12644.   Flags: DWORD;
  12645. begin
  12646.   Flags := 0;
  12647.   if Double(MinVal) <> 0.0 then
  12648.   begin
  12649.     Flags := Flags or GDTR_MIN;
  12650.     DateTimeToSystemTime(MinVal, STA[1]);
  12651.   end;
  12652.   if Double(MaxVal) <> 0.0 then
  12653.   begin
  12654.     Flags := Flags or GDTR_MIN;
  12655.     DateTimeToSystemTime(MaxVal, STA[2]);
  12656.   end;
  12657.   if Flags <> 0 then DateTime_SetRange(Handle, Flags, @STA[1]);
  12658. end;
  12659.  
  12660. procedure TDateTimePicker.SetDateFormat(Value: TDTDateFormat);
  12661. begin
  12662.   if FDateFormat <> Value then
  12663.   begin
  12664.     FDateFormat := Value;
  12665.     RecreateWnd;
  12666.   end;
  12667. end;
  12668.  
  12669. procedure TDateTimePicker.SetDateMode(Value: TDTDateMode);
  12670. begin
  12671.   if FDateMode <> Value then
  12672.   begin
  12673.     FDateMode := Value;
  12674.     RecreateWnd;
  12675.   end;
  12676. end;
  12677.  
  12678. procedure TDateTimePicker.SetKind(Value: TDateTimeKind);
  12679. begin
  12680.   if FKind <> Value then
  12681.   begin
  12682.     FKind := Value;
  12683.     RecreateWnd;
  12684.   end;
  12685. end;
  12686.  
  12687. procedure TDateTimePicker.SetParseInput(Value: Boolean);
  12688. begin
  12689.   if FParseInput <> Value then
  12690.   begin
  12691.     FParseInput := Value;
  12692.     if not (csDesigning in ComponentState) then RecreateWnd;
  12693.   end;
  12694. end;
  12695.  
  12696. procedure TDateTimePicker.SetShowCheckbox(Value: Boolean);
  12697. begin
  12698.   if FShowCheckbox <> Value then
  12699.   begin
  12700.     FShowCheckbox := Value;
  12701.     RecreateWnd;
  12702.   end;
  12703. end;
  12704.  
  12705. procedure TDateTimePicker.SetTime(Value: TTime);
  12706. begin
  12707.   if Frac(FDateTime) <> Frac(Value) then
  12708.   begin
  12709.     if Double(Value) = 0.0 then
  12710.     begin
  12711.       if not FShowCheckbox then raise EDateTimeError.Create(SNeedAllowNone);
  12712.       SetShowCheckbox(True);
  12713.     end
  12714.     else begin
  12715.       Value := Trunc(FDateTime) + Frac(Value);
  12716.       SetDateTime(Value);
  12717.     end;
  12718.   end;
  12719. end;
  12720.  
  12721. initialization
  12722.  
  12723. finalization
  12724.   if ShellModule <> 0 then FreeLibrary(ShellModule);
  12725.   
  12726. end.
  12727.